1 /* xleval - xlisp evaluator */
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 eliminated some compiler warnings
8 12 Oct 90 RBD added profiling support
9 */
10
11 #include "string.h"
12 #include "xlisp.h"
13
14 /* macro to check for lambda list keywords */
15 #define iskey(s) ((s) == lk_optional \
16 || (s) == lk_rest \
17 || (s) == lk_key \
18 || (s) == lk_aux \
19 || (s) == lk_allow_other_keys)
20
21 /* macros to handle tracing */
22 #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
23 #define trexit(sym,val) {if (sym) doexit(sym,val);}
24
25
26
27 /* forward declarations */
28 FORWARD LOCAL LVAL evalhook(LVAL expr);
29 FORWARD LOCAL LVAL evform(LVAL form);
30 FORWARD LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv);
31 FORWARD LVAL xlclose(LVAL name, LVAL type, LVAL fargs, LVAL body, LVAL env, LVAL fenv);
32 FORWARD LOCAL int member( LVAL x, LVAL list);
33 FORWARD LOCAL int evpushargs(LVAL fun, LVAL args);
34 FORWARD LOCAL void doenter(LVAL sym, int argc, LVAL *argv);
35 FORWARD LOCAL void doexit(LVAL sym, LVAL val);
36 FORWARD LOCAL void badarglist(void);
37
38 /* profiling extensions by RBD */
39 extern LVAL s_profile, profile_fixnum;
40 extern FIXTYPE *profile_count_ptr, profile_flag;
41
42 /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
xleval(LVAL expr)43 LVAL xleval(LVAL expr)
44 {
45 /* check for control codes */
46 if (--xlsample <= 0) {
47 xlsample = SAMPLE;
48 run_time++;
49 oscheck();
50 }
51
52 /* check for *evalhook* */
53 if (getvalue(s_evalhook))
54 return (evalhook(expr));
55
56 /* check for nil */
57 if (null(expr))
58 return (NIL);
59
60 /* dispatch on the node type */
61 switch (ntype(expr)) {
62 case CONS:
63 return (evform(expr));
64 case SYMBOL:
65 return (xlgetvalue(expr));
66 default:
67 return (expr);
68 }
69 }
70
71 /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
xlxeval(LVAL expr)72 LVAL xlxeval(LVAL expr)
73 {
74 /* check for nil */
75 if (null(expr))
76 return (NIL);
77
78 /* dispatch on node type */
79 switch (ntype(expr)) {
80 case CONS:
81 return (evform(expr));
82 case SYMBOL:
83 return (xlgetvalue(expr));
84 default:
85 return (expr);
86 }
87 }
88
89 /* xlapply - apply a function to arguments (already on the stack) */
xlapply(int argc)90 LVAL xlapply(int argc)
91 {
92 LVAL *oldargv,fun,val=NULL;
93 LVAL funname;
94 LVAL old_profile_fixnum = profile_fixnum;
95 FIXTYPE *old_profile_count_ptr = profile_count_ptr;
96 int oldargc;
97
98 /* get the function */
99 fun = xlfp[1];
100
101 /* get the functional value of symbols */
102 if (symbolp(fun)) {
103 funname = fun; /* save it */
104 while ((val = getfunction(fun)) == s_unbound)
105 xlfunbound(fun);
106 fun = xlfp[1] = val;
107
108 if (profile_flag && atomp(funname)) {
109 LVAL profile_prop = findprop(funname, s_profile);
110 if (null(profile_prop)) {
111 /* make a new fixnum, don't use cvfixnum because
112 it would return shared pointer to zero, but we
113 are going to modify this integer in place --
114 dangerous but efficient.
115 */
116 profile_fixnum = newnode(FIXNUM);
117 profile_fixnum->n_fixnum = 0;
118 setplist(funname, cons(s_profile,
119 cons(profile_fixnum,
120 getplist(funname))));
121 setvalue(s_profile, cons(funname, getvalue(s_profile)));
122 } else profile_fixnum = car(profile_prop);
123 profile_count_ptr = &getfixnum(profile_fixnum);
124 }
125 }
126
127 /* check for nil */
128 if (null(fun))
129 xlerror("bad function",fun);
130
131 /* dispatch on node type */
132 switch (ntype(fun)) {
133 case SUBR:
134 oldargc = xlargc;
135 oldargv = xlargv;
136 xlargc = argc;
137 xlargv = xlfp + 3;
138 val = (*getsubr(fun))();
139 xlargc = oldargc;
140 xlargv = oldargv;
141 break;
142 case CONS:
143 if (!consp(cdr(fun)))
144 xlerror("bad function",fun);
145 if (car(fun) == s_lambda) {
146 fun = xlclose(NIL,
147 s_lambda,
148 car(cdr(fun)),
149 cdr(cdr(fun)),
150 xlenv,xlfenv);
151 } else
152 xlerror("bad function",fun);
153 /**** fall through into the next case ****/
154 case CLOSURE:
155 if (gettype(fun) != s_lambda)
156 xlerror("bad function",fun);
157 val = evfun(fun,argc,xlfp+3);
158 break;
159 default:
160 xlerror("bad function",fun);
161 }
162
163 /* restore original profile counting state */
164 profile_fixnum = old_profile_fixnum;
165 profile_count_ptr = old_profile_count_ptr;
166
167 /* remove the call frame */
168 xlsp = xlfp;
169 xlfp = xlfp - (int)getfixnum(*xlfp);
170
171 /* return the function value */
172 return (val);
173 }
174
175 /* evform - evaluate a form */
evform(LVAL form)176 LOCAL LVAL evform(LVAL form)
177 {
178 LVAL fun,args,val=NULL,type;
179 LVAL tracing=NIL;
180 LVAL *argv;
181 LVAL old_profile_fixnum = profile_fixnum;
182 FIXTYPE *old_profile_count_ptr = profile_count_ptr;
183 LVAL funname;
184 int argc;
185
186 /* protect some pointers */
187 xlstkcheck(2);
188 xlsave(fun);
189 xlsave(args);
190
191 (*profile_count_ptr)++; /* increment profile counter */
192
193 /* get the function and the argument list */
194 fun = car(form);
195 args = cdr(form);
196
197 funname = fun;
198
199 /* get the functional value of symbols */
200 if (symbolp(fun)) {
201 if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
202 tracing = fun;
203 fun = xlgetfunction(fun);
204 }
205
206 /* check for nil */
207 if (null(fun))
208 xlerror("bad function",NIL);
209
210 /* dispatch on node type */
211 switch (ntype(fun)) {
212 case SUBR:
213 argv = xlargv;
214 argc = xlargc;
215 xlargc = evpushargs(fun,args);
216 xlargv = xlfp + 3;
217 trenter(tracing,xlargc,xlargv);
218 val = (*getsubr(fun))();
219 trexit(tracing,val);
220 xlsp = xlfp;
221 xlfp = xlfp - (int)getfixnum(*xlfp);
222 xlargv = argv;
223 xlargc = argc;
224 break;
225 case FSUBR:
226 argv = xlargv;
227 argc = xlargc;
228 xlargc = pushargs(fun,args);
229 xlargv = xlfp + 3;
230 val = (*getsubr(fun))();
231 xlsp = xlfp;
232 xlfp = xlfp - (int)getfixnum(*xlfp);
233 xlargv = argv;
234 xlargc = argc;
235 break;
236 case CONS:
237 if (!consp(cdr(fun)))
238 xlerror("bad function",fun);
239 if ((type = car(fun)) == s_lambda)
240 fun = xlclose(NIL,
241 s_lambda,
242 car(cdr(fun)),
243 cdr(cdr(fun)),
244 xlenv,xlfenv);
245 else
246 xlerror("bad function",fun);
247 /**** fall through into the next case ****/
248 case CLOSURE:
249 /* do profiling */
250 if (profile_flag && atomp(funname)) {
251 LVAL profile_prop = findprop(funname, s_profile);
252 if (null(profile_prop)) {
253 /* make a new fixnum, don't use cvfixnum because
254 it would return shared pointer to zero, but we
255 are going to modify this integer in place --
256 dangerous but efficient.
257 */
258 profile_fixnum = newnode(FIXNUM);
259 profile_fixnum->n_fixnum = 0;
260 setplist(funname, cons(s_profile,
261 cons(profile_fixnum,
262 getplist(funname))));
263 setvalue(s_profile, cons(funname, getvalue(s_profile)));
264 } else profile_fixnum = car(profile_prop);
265 profile_count_ptr = &getfixnum(profile_fixnum);
266 }
267
268 if (gettype(fun) == s_lambda) {
269 argc = evpushargs(fun,args);
270 argv = xlfp + 3;
271 trenter(tracing,argc,argv);
272 val = evfun(fun,argc,argv);
273 trexit(tracing,val);
274 xlsp = xlfp;
275 xlfp = xlfp - (int)getfixnum(*xlfp);
276 }
277 else {
278 macroexpand(fun,args,&fun);
279 val = xleval(fun);
280 }
281 profile_fixnum = old_profile_fixnum;
282 profile_count_ptr = old_profile_count_ptr;
283 break;
284 default:
285 xlerror("bad function",fun);
286 }
287
288 /* restore the stack */
289 xlpopn(2);
290
291 /* return the result value */
292 return (val);
293 }
294
295 /* xlexpandmacros - expand macros in a form */
xlexpandmacros(LVAL form)296 LVAL xlexpandmacros(LVAL form)
297 {
298 LVAL fun,args;
299
300 /* protect some pointers */
301 xlstkcheck(3);
302 xlprotect(form);
303 xlsave(fun);
304 xlsave(args);
305
306 /* expand until the form isn't a macro call */
307 while (consp(form)) {
308 fun = car(form); /* get the macro name */
309 args = cdr(form); /* get the arguments */
310 if (!symbolp(fun) || !fboundp(fun))
311 break;
312 fun = xlgetfunction(fun); /* get the expansion function */
313 if (!macroexpand(fun,args,&form))
314 break;
315 }
316
317 /* restore the stack and return the expansion */
318 xlpopn(3);
319 return (form);
320 }
321
322 /* macroexpand - expand a macro call */
macroexpand(LVAL fun,LVAL args,LVAL * pval)323 int macroexpand(LVAL fun, LVAL args, LVAL *pval)
324 {
325 LVAL *argv;
326 int argc;
327
328 /* make sure it's really a macro call */
329 if (!closurep(fun) || gettype(fun) != s_macro)
330 return (FALSE);
331
332 /* call the expansion function */
333 argc = pushargs(fun,args);
334 argv = xlfp + 3;
335 *pval = evfun(fun,argc,argv);
336 xlsp = xlfp;
337 xlfp = xlfp - (int)getfixnum(*xlfp);
338 return (TRUE);
339 }
340
341 /* evalhook - call the evalhook function */
evalhook(LVAL expr)342 LOCAL LVAL evalhook(LVAL expr)
343 {
344 LVAL *newfp,olddenv,val;
345
346 /* create the new call frame */
347 newfp = xlsp;
348 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
349 pusharg(getvalue(s_evalhook));
350 pusharg(cvfixnum((FIXTYPE)2));
351 pusharg(expr);
352 pusharg(cons(xlenv,xlfenv));
353 xlfp = newfp;
354
355 /* rebind the hook functions to nil */
356 olddenv = xldenv;
357 xldbind(s_evalhook,NIL);
358 xldbind(s_applyhook,NIL);
359
360 /* call the hook function */
361 val = xlapply(2);
362
363 /* unbind the symbols */
364 xlunbind(olddenv);
365
366 /* return the value */
367 return (val);
368 }
369
370 /* evpushargs - evaluate and push a list of arguments */
evpushargs(LVAL fun,LVAL args)371 LOCAL int evpushargs(LVAL fun, LVAL args)
372 {
373 LVAL *newfp;
374 int argc;
375
376 /* protect the argument list */
377 xlprot1(args);
378
379 /* build a new argument stack frame */
380 newfp = xlsp;
381 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
382 pusharg(fun);
383 pusharg(NIL); /* will be argc */
384 /* evaluate and push each argument */
385 for (argc = 0; consp(args); args = cdr(args), ++argc) {
386 pusharg(xleval(car(args)));
387 }
388 /* establish the new stack frame */
389 newfp[2] = cvfixnum((FIXTYPE)argc);
390 xlfp = newfp;
391
392 /* restore the stack */
393 xlpop();
394
395 /* return the number of arguments */
396 return (argc);
397 }
398
399 /* pushargs - push a list of arguments */
pushargs(LVAL fun,LVAL args)400 int pushargs(LVAL fun, LVAL args)
401 {
402 LVAL *newfp;
403 int argc;
404
405 /* build a new argument stack frame */
406 newfp = xlsp;
407 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
408 pusharg(fun);
409 pusharg(NIL); /* will be argc */
410
411 /* push each argument */
412 for (argc = 0; consp(args); args = cdr(args), ++argc)
413 pusharg(car(args));
414
415 /* establish the new stack frame */
416 newfp[2] = cvfixnum((FIXTYPE)argc);
417 xlfp = newfp;
418
419 /* return the number of arguments */
420 return (argc);
421 }
422
423 /* makearglist - make a list of the remaining arguments */
makearglist(int argc,LVAL * argv)424 LVAL makearglist(int argc, LVAL *argv)
425 {
426 LVAL list,this,last;
427 xlsave1(list);
428 for (last = NIL; --argc >= 0; last = this) {
429 this = cons(*argv++,NIL);
430 if (last) rplacd(last,this);
431 else list = this;
432 last = this;
433 }
434 xlpop();
435 return (list);
436 }
437
438 /* evfun - evaluate a function */
evfun(LVAL fun,int argc,LVAL * argv)439 LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv)
440 {
441 LVAL oldenv,oldfenv,cptr,name,val;
442 XLCONTEXT cntxt;
443
444 /* protect some pointers */
445 xlstkcheck(4);
446 xlsave(oldenv);
447 xlsave(oldfenv);
448 xlsave(cptr);
449 xlprotect(fun); /* (RBD) Otherwise, fun is unprotected */
450
451 /* create a new environment frame */
452 oldenv = xlenv;
453 oldfenv = xlfenv;
454 xlenv = xlframe(closure_getenv(fun));
455 xlfenv = getfenv(fun);
456
457 /* bind the formal parameters */
458 xlabind(fun,argc,argv);
459
460 /* setup the implicit block */
461 if ((name = getname(fun)))
462 xlbegin(&cntxt,CF_RETURN,name);
463
464 /* execute the block */
465 if (name && _setjmp(cntxt.c_jmpbuf))
466 val = xlvalue;
467 else
468 for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
469 val = xleval(car(cptr));
470
471 /* finish the block context */
472 if (name)
473 xlend(&cntxt);
474
475 /* restore the environment */
476 xlenv = oldenv;
477 xlfenv = oldfenv;
478
479 /* restore the stack */
480 xlpopn(4);
481
482 /* return the result value */
483 return (val);
484 }
485
486 /* xlclose - create a function closure */
xlclose(LVAL name,LVAL type,LVAL fargs,LVAL body,LVAL env,LVAL fenv)487 LVAL xlclose(LVAL name, LVAL type, LVAL fargs, LVAL body, LVAL env, LVAL fenv)
488 {
489 LVAL closure,key=NULL,arg,def,svar,new,last;
490 char keyname[STRMAX+2];
491
492 /* protect some pointers */
493 xlsave1(closure);
494
495 /* create the closure object */
496 closure = newclosure(name,type,env,fenv);
497 setlambda(closure,fargs);
498 setbody(closure,body);
499
500 /* handle each required argument */
501 last = NIL;
502 while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
503
504 /* make sure the argument is a symbol */
505 if (!symbolp(arg))
506 badarglist();
507
508 /* create a new argument list entry */
509 new = cons(arg,NIL);
510
511 /* link it into the required argument list */
512 if (last)
513 rplacd(last,new);
514 else
515 setargs(closure,new);
516 last = new;
517
518 /* move the formal argument list pointer ahead */
519 fargs = cdr(fargs);
520 }
521
522 /* check for the '&optional' keyword */
523 if (consp(fargs) && car(fargs) == lk_optional) {
524 fargs = cdr(fargs);
525
526 /* handle each optional argument */
527 last = NIL;
528 while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
529
530 /* get the default expression and specified-p variable */
531 def = svar = NIL;
532 if (consp(arg)) {
533 if ((def = cdr(arg))) {
534 if (consp(def)) {
535 if ((svar = cdr(def))) {
536 if (consp(svar)) {
537 svar = car(svar);
538 if (!symbolp(svar))
539 badarglist();
540 }
541 else
542 badarglist();
543 }
544 def = car(def);
545 }
546 else
547 badarglist();
548 }
549 arg = car(arg);
550 }
551
552 /* make sure the argument is a symbol */
553 if (!symbolp(arg))
554 badarglist();
555
556 /* create a fully expanded optional expression */
557 new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
558
559 /* link it into the optional argument list */
560 if (last)
561 rplacd(last,new);
562 else
563 setoargs(closure,new);
564 last = new;
565
566 /* move the formal argument list pointer ahead */
567 fargs = cdr(fargs);
568 }
569 }
570
571 /* check for the '&rest' keyword */
572 if (consp(fargs) && car(fargs) == lk_rest) {
573 fargs = cdr(fargs);
574
575 /* get the &rest argument */
576 if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
577 setrest(closure,arg);
578 else
579 badarglist();
580
581 /* move the formal argument list pointer ahead */
582 fargs = cdr(fargs);
583 }
584
585 /* check for the '&key' keyword */
586 if (consp(fargs) && car(fargs) == lk_key) {
587 fargs = cdr(fargs);
588
589 /* handle each key argument */
590 last = NIL;
591 while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
592
593 /* get the default expression and specified-p variable */
594 def = svar = NIL;
595 if (consp(arg)) {
596 if ((def = cdr(arg))) {
597 if (consp(def)) {
598 if ((svar = cdr(def))) {
599 if (consp(svar)) {
600 svar = car(svar);
601 if (!symbolp(svar))
602 badarglist();
603 }
604 else
605 badarglist();
606 }
607 def = car(def);
608 }
609 else
610 badarglist();
611 }
612 arg = car(arg);
613 }
614
615 /* get the keyword and the variable */
616 if (consp(arg)) {
617 key = car(arg);
618 if (!symbolp(key))
619 badarglist();
620 if ((arg = cdr(arg))) {
621 if (consp(arg))
622 arg = car(arg);
623 else
624 badarglist();
625 }
626 }
627 else if (symbolp(arg)) {
628 strcpy(keyname,":");
629 strcat(keyname,(char *) getstring(getpname(arg)));
630 key = xlenter(keyname);
631 }
632
633 /* make sure the argument is a symbol */
634 if (!symbolp(arg))
635 badarglist();
636
637 /* create a fully expanded key expression */
638 new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
639
640 /* link it into the optional argument list */
641 if (last)
642 rplacd(last,new);
643 else
644 setkargs(closure,new);
645 last = new;
646
647 /* move the formal argument list pointer ahead */
648 fargs = cdr(fargs);
649 }
650 }
651
652 /* check for the '&allow-other-keys' keyword */
653 if (consp(fargs) && car(fargs) == lk_allow_other_keys)
654 fargs = cdr(fargs); /* this is the default anyway */
655
656 /* check for the '&aux' keyword */
657 if (consp(fargs) && car(fargs) == lk_aux) {
658 fargs = cdr(fargs);
659
660 /* handle each aux argument */
661 last = NIL;
662 while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
663
664 /* get the initial value */
665 def = NIL;
666 if (consp(arg)) {
667 if ((def = cdr(arg))) {
668 if (consp(def))
669 def = car(def);
670 else
671 badarglist();
672 }
673 arg = car(arg);
674 }
675
676 /* make sure the argument is a symbol */
677 if (!symbolp(arg))
678 badarglist();
679
680 /* create a fully expanded aux expression */
681 new = cons(cons(arg,cons(def,NIL)),NIL);
682
683 /* link it into the aux argument list */
684 if (last)
685 rplacd(last,new);
686 else
687 setaargs(closure,new);
688 last = new;
689
690 /* move the formal argument list pointer ahead */
691 fargs = cdr(fargs);
692 }
693 }
694
695 /* make sure this is the end of the formal argument list */
696 if (fargs)
697 badarglist();
698
699 /* restore the stack */
700 xlpop();
701
702 /* return the new closure */
703 return (closure);
704 }
705
706 /* xlabind - bind the arguments for a function */
xlabind(LVAL fun,int argc,LVAL * argv)707 void xlabind(LVAL fun, int argc, LVAL *argv)
708 {
709 LVAL *kargv,fargs,key,arg,def,svar,p;
710 int rargc,kargc;
711 /* protect some pointers */
712 xlsave1(def);
713
714 /* bind each required argument */
715 for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
716 /* make sure there is an actual argument */
717 if (--argc < 0)
718 xlfail("too few arguments");
719
720 /* bind the formal variable to the argument value */
721 xlbind(car(fargs),*argv++);
722 }
723
724 /* bind each optional argument */
725 for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
726
727 /* get argument, default and specified-p variable */
728 p = car(fargs);
729 arg = car(p); p = cdr(p);
730 def = car(p); p = cdr(p);
731 svar = car(p);
732
733 /* bind the formal variable to the argument value */
734 if (--argc >= 0) {
735 xlbind(arg,*argv++);
736 if (svar) xlbind(svar,s_true);
737 }
738
739 /* bind the formal variable to the default value */
740 else {
741 if (def) def = xleval(def);
742 xlbind(arg,def);
743 if (svar) xlbind(svar,NIL);
744 }
745 }
746
747 /* save the count of the &rest of the argument list */
748 rargc = argc;
749
750 /* handle '&rest' argument */
751 if ((arg = getrest(fun))) {
752 def = makearglist(argc,argv);
753 xlbind(arg,def);
754 argc = 0;
755 }
756
757 /* handle '&key' arguments */
758 if ((fargs = getkargs(fun))) {
759 for (; fargs; fargs = cdr(fargs)) {
760
761 /* get keyword, argument, default and specified-p variable */
762 p = car(fargs);
763 key = car(p); p = cdr(p);
764 arg = car(p); p = cdr(p);
765 def = car(p); p = cdr(p);
766 svar = car(p);
767
768 /* look for the keyword in the actual argument list */
769 for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
770 if (*kargv == key)
771 break;
772
773 /* bind the formal variable to the argument value */
774 if (kargc >= 0) {
775 xlbind(arg,*++kargv);
776 if (svar) xlbind(svar,s_true);
777 }
778
779 /* bind the formal variable to the default value */
780 else {
781 if (def) def = xleval(def);
782 xlbind(arg,def);
783 if (svar) xlbind(svar,NIL);
784 }
785 }
786 argc = 0;
787 }
788
789 /* check for the '&aux' keyword */
790 for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
791
792 /* get argument and default */
793 p = car(fargs);
794 arg = car(p); p = cdr(p);
795 def = car(p);
796
797 /* bind the auxiliary variable to the initial value */
798 if (def) def = xleval(def);
799 xlbind(arg,def);
800 }
801
802 /* make sure there aren't too many arguments */
803 if (argc > 0)
804 xlfail("too many arguments");
805
806 /* restore the stack */
807 xlpop();
808 }
809
810 /* doenter - print trace information on function entry */
doenter(LVAL sym,int argc,LVAL * argv)811 LOCAL void doenter(LVAL sym, int argc, LVAL *argv)
812 {
813 extern int xltrcindent;
814 int i;
815
816 /* indent to the current trace level */
817 for (i = 0; i < xltrcindent; ++i)
818 trcputstr(" ");
819 ++xltrcindent;
820
821 /* display the function call */
822 snprintf(buf, STRMAX, "Entering: %s, Argument list: (", getstring(getpname(sym)));
823 trcputstr(buf);
824 while (--argc >= 0) {
825 trcprin1(*argv++);
826 if (argc) trcputstr(" ");
827 }
828 trcputstr(")\n");
829 }
830
831 /* doexit - print trace information for function/macro exit */
doexit(LVAL sym,LVAL val)832 LOCAL void doexit(LVAL sym, LVAL val)
833 {
834 extern int xltrcindent;
835 int i;
836
837 /* indent to the current trace level */
838 --xltrcindent;
839 for (i = 0; i < xltrcindent; ++i)
840 trcputstr(" ");
841
842 /* display the function value */
843 snprintf(buf, STRMAX, "Exiting: %s, Value: ", getstring(getpname(sym)));
844 trcputstr(buf);
845 trcprin1(val);
846 trcputstr("\n");
847 }
848
849 /* member - is 'x' a member of 'list'? */
member(LVAL x,LVAL list)850 LOCAL int member( LVAL x, LVAL list)
851 {
852 for (; consp(list); list = cdr(list))
853 if (x == car(list))
854 return (TRUE);
855 return (FALSE);
856 }
857
858 /* xlunbound - signal an unbound variable error */
xlunbound(LVAL sym)859 void xlunbound(LVAL sym)
860 {
861 xlcerror("try evaluating symbol again","unbound variable",sym);
862 }
863
864 /* xlfunbound - signal an unbound function error */
xlfunbound(LVAL sym)865 void xlfunbound(LVAL sym)
866 {
867 xlcerror("try evaluating symbol again","unbound function",sym);
868 }
869
870 /* xlstkoverflow - signal a stack overflow error */
xlstkoverflow(void)871 void xlstkoverflow(void)
872 {
873 xlabort("evaluation stack overflow");
874 }
875
876 /* xlargstkoverflow - signal an argument stack overflow error */
xlargstkoverflow(void)877 void xlargstkoverflow(void)
878 {
879 xlabort("argument stack overflow");
880 }
881
882 /* badarglist - report a bad argument list error */
badarglist(void)883 LOCAL void badarglist(void)
884 {
885 xlfail("bad formal argument list");
886 }
887