1 /* xlcont - xlisp special forms */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 /* CHANGE LOG
7 * --------------------------------------------------------------------
8 * 28Apr03 dm eliminate some compiler warnings
9 */
10
11
12 #include "xlisp.h"
13
14 /* external variables */
15 extern LVAL xlvalue;
16 extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
17 extern LVAL s_svalue,s_sfunction,s_splist;
18 extern LVAL s_lambda,s_macro;
19
20 /* forward declarations */
21 FORWARD LOCAL LVAL bquote1(LVAL expr);
22 FORWARD LOCAL void placeform(LVAL place, LVAL value);
23 FORWARD LOCAL LVAL let(int pflag);
24 FORWARD LOCAL LVAL flet(LVAL type, int letflag);
25 FORWARD LOCAL LVAL prog(int pflag);
26 FORWARD LOCAL LVAL progx(int n);
27 FORWARD LOCAL LVAL doloop(int pflag);
28 FORWARD LOCAL LVAL evarg(LVAL *pargs);
29 FORWARD LOCAL LVAL match(int type, LVAL *pargs);
30 FORWARD LOCAL LVAL evmatch(int type, LVAL *pargs);
31 FORWARD LOCAL void toofew(LVAL args);
32 FORWARD LOCAL void toomany(LVAL args);
33 FORWARD LOCAL void setffunction(LVAL fun, LVAL place, LVAL value);
34 FORWARD LOCAL int keypresent(LVAL key, LVAL list);
35 FORWARD LOCAL void dobindings(LVAL list, LVAL env);
36 FORWARD LOCAL void tagbody(void);
37 FORWARD LOCAL void doupdates(LVAL list, int pflag);
38
39
40 /* dummy node type for a list */
41 #define LIST -1
42
43 /* xquote - special form 'quote' */
xquote(void)44 LVAL xquote(void)
45 {
46 LVAL val;
47 val = xlgetarg();
48 xllastarg();
49 return (val);
50 }
51
52 /* xfunction - special form 'function' */
xfunction(void)53 LVAL xfunction(void)
54 {
55 LVAL val;
56
57 /* get the argument */
58 val = xlgetarg();
59 xllastarg();
60
61 /* create a closure for lambda expressions */
62 if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
63 val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
64
65 /* otherwise, get the value of a symbol */
66 else if (symbolp(val))
67 val = xlgetfunction(val);
68
69 /* otherwise, its an error */
70 else
71 xlerror("not a function",val);
72
73 /* return the function */
74 return (val);
75 }
76
77 /* xbquote - back quote special form */
xbquote(void)78 LVAL xbquote(void)
79 {
80 LVAL expr;
81
82 /* get the expression */
83 expr = xlgetarg();
84 xllastarg();
85
86 /* fill in the template */
87 return (bquote1(expr));
88 }
89
90 /* bquote1 - back quote helper function */
bquote1(LVAL expr)91 LOCAL LVAL bquote1(LVAL expr)
92 {
93 LVAL val,list,last,new;
94
95 /* handle atoms */
96 if (atomp(expr))
97 val = expr;
98
99 /* handle (comma <expr>) */
100 else if (car(expr) == s_comma) {
101 if (atomp(cdr(expr)))
102 xlfail("bad comma expression");
103 val = xleval(car(cdr(expr)));
104 }
105
106 /* handle ((comma-at <expr>) ... ) */
107 else if (consp(car(expr)) && car(car(expr)) == s_comat) {
108 xlstkcheck(2);
109 xlsave(list);
110 xlsave(val);
111 if (atomp(cdr(car(expr))))
112 xlfail("bad comma-at expression");
113 list = xleval(car(cdr(car(expr))));
114 for (last = NIL; consp(list); list = cdr(list)) {
115 new = consa(car(list));
116 if (last)
117 rplacd(last,new);
118 else
119 val = new;
120 last = new;
121 }
122 if (last)
123 rplacd(last,bquote1(cdr(expr)));
124 else
125 val = bquote1(cdr(expr));
126 xlpopn(2);
127 }
128
129 /* handle any other list */
130 else {
131 xlsave1(val);
132 val = consa(NIL);
133 rplaca(val,bquote1(car(expr)));
134 rplacd(val,bquote1(cdr(expr)));
135 xlpop();
136 }
137
138 /* return the result */
139 return (val);
140 }
141
142 /* xlambda - special form 'lambda' */
xlambda(void)143 LVAL xlambda(void)
144 {
145 LVAL fargs,arglist,val;
146
147 /* get the formal argument list and function body */
148 xlsave1(arglist);
149 fargs = xlgalist();
150 arglist = makearglist(xlargc,xlargv);
151
152 /* create a new function definition */
153 val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
154
155 /* restore the stack and return the closure */
156 xlpop();
157 return (val);
158 }
159
160 /* xgetlambda - get the lambda expression associated with a closure */
xgetlambda(void)161 LVAL xgetlambda(void)
162 {
163 LVAL closure;
164 closure = xlgaclosure();
165 return (cons(gettype(closure),
166 cons(getlambda(closure),getbody(closure))));
167 }
168
169 /* xsetq - special form 'setq' */
xsetq(void)170 LVAL xsetq(void)
171 {
172 LVAL sym,val;
173
174 /* handle each pair of arguments */
175 for (val = NIL; moreargs(); ) {
176 sym = xlgasymbol();
177 val = xleval(nextarg());
178 xlsetvalue(sym,val);
179 }
180
181 /* return the result value */
182 return (val);
183 }
184
185 /* xpsetq - special form 'psetq' */
xpsetq(void)186 LVAL xpsetq(void)
187 {
188 LVAL plist,sym,val;
189
190 /* protect some pointers */
191 xlsave1(plist);
192
193 /* handle each pair of arguments */
194 for (val = NIL; moreargs(); ) {
195 sym = xlgasymbol();
196 val = xleval(nextarg());
197 plist = cons(cons(sym,val),plist);
198 }
199
200 /* do parallel sets */
201 for (; plist; plist = cdr(plist))
202 xlsetvalue(car(car(plist)),cdr(car(plist)));
203
204 /* restore the stack */
205 xlpop();
206
207 /* return the result value */
208 return (val);
209 }
210
211 /* xsetf - special form 'setf' */
xsetf(void)212 LVAL xsetf(void)
213 {
214 LVAL place,value;
215
216 /* protect some pointers */
217 xlsave1(value);
218
219 /* handle each pair of arguments */
220 while (moreargs()) {
221
222 /* get place and value */
223 place = xlgetarg();
224 value = xleval(nextarg());
225
226 /* expand macros in the place form */
227 if (consp(place))
228 place = xlexpandmacros(place);
229
230 /* check the place form */
231 if (symbolp(place))
232 xlsetvalue(place,value);
233 else if (consp(place))
234 placeform(place,value);
235 else
236 xlfail("bad place form");
237 }
238
239 /* restore the stack */
240 xlpop();
241
242 /* return the value */
243 return (value);
244 }
245
246 /* placeform - handle a place form other than a symbol */
placeform(LVAL place,LVAL value)247 LOCAL void placeform(LVAL place, LVAL value)
248 {
249 LVAL fun,arg1,arg2;
250 int i;
251
252 /* check the function name */
253 if ((fun = match(SYMBOL,&place)) == s_get) {
254 xlstkcheck(2);
255 xlsave(arg1);
256 xlsave(arg2);
257 arg1 = evmatch(SYMBOL,&place);
258 arg2 = evmatch(SYMBOL,&place);
259 if (place) toomany(place);
260 xlputprop(arg1,value,arg2);
261 xlpopn(2);
262 }
263 else if (fun == s_svalue) {
264 arg1 = evmatch(SYMBOL,&place);
265 if (place) toomany(place);
266 setvalue(arg1,value);
267 }
268 else if (fun == s_sfunction) {
269 arg1 = evmatch(SYMBOL,&place);
270 if (place) toomany(place);
271 setfunction(arg1,value);
272 }
273 else if (fun == s_splist) {
274 arg1 = evmatch(SYMBOL,&place);
275 if (place) toomany(place);
276 setplist(arg1,value);
277 }
278 else if (fun == s_car) {
279 arg1 = evmatch(CONS,&place);
280 if (place) toomany(place);
281 rplaca(arg1,value);
282 }
283 else if (fun == s_cdr) {
284 arg1 = evmatch(CONS,&place);
285 if (place) toomany(place);
286 rplacd(arg1,value);
287 }
288 else if (fun == s_nth) {
289 xlsave1(arg1);
290 arg1 = evmatch(FIXNUM,&place);
291 arg2 = evmatch(LIST,&place);
292 if (place) toomany(place);
293 for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
294 arg2 = cdr(arg2);
295 if (consp(arg2))
296 rplaca(arg2,value);
297 xlpop();
298 }
299 else if (fun == s_aref) {
300 xlsave1(arg1);
301 arg1 = evmatch(VECTOR,&place);
302 arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
303 if (place) toomany(place);
304 if (i < 0 || i >= getsize(arg1))
305 xlerror("index out of range",arg2);
306 setelement(arg1,i,value);
307 xlpop();
308 }
309 else if ((fun = xlgetprop(fun,s_setf)))
310 setffunction(fun,place,value);
311 else
312 xlfail("bad place form");
313 }
314
315 /* setffunction - call a user defined setf function */
setffunction(LVAL fun,LVAL place,LVAL value)316 LOCAL void setffunction(LVAL fun, LVAL place, LVAL value)
317 {
318 LVAL *newfp;
319 int argc;
320
321 /* create the new call frame */
322 newfp = xlsp;
323 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
324 pusharg(fun);
325 pusharg(NIL);
326
327 /* push the values of all of the place expressions and the new value */
328 for (argc = 1; consp(place); place = cdr(place), ++argc)
329 pusharg(xleval(car(place)));
330 pusharg(value);
331
332 /* insert the argument count and establish the call frame */
333 newfp[2] = cvfixnum((FIXTYPE)argc);
334 xlfp = newfp;
335
336 /* apply the function */
337 xlapply(argc);
338 }
339
340 /* xdefun - special form 'defun' */
xdefun(void)341 LVAL xdefun(void)
342 {
343 LVAL sym,fargs,arglist;
344
345 /* get the function symbol and formal argument list */
346 xlsave1(arglist);
347 sym = xlgasymbol();
348 fargs = xlgalist();
349 arglist = makearglist(xlargc,xlargv);
350
351 /* make the symbol point to a new function definition */
352 xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
353
354 /* restore the stack and return the function symbol */
355 xlpop();
356 return (sym);
357 }
358
359 /* xdefmacro - special form 'defmacro' */
xdefmacro(void)360 LVAL xdefmacro(void)
361 {
362 LVAL sym,fargs,arglist;
363
364 /* get the function symbol and formal argument list */
365 xlsave1(arglist);
366 sym = xlgasymbol();
367 fargs = xlgalist();
368 arglist = makearglist(xlargc,xlargv);
369
370 /* make the symbol point to a new function definition */
371 xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
372
373 /* restore the stack and return the function symbol */
374 xlpop();
375 return (sym);
376 }
377
378 /* xcond - special form 'cond' */
xcond(void)379 LVAL xcond(void)
380 {
381 LVAL list,val;
382
383 /* find a predicate that is true */
384 for (val = NIL; moreargs(); ) {
385
386 /* get the next conditional */
387 list = nextarg();
388
389 /* evaluate the predicate part */
390 if (consp(list) && (val = xleval(car(list)))) {
391
392 /* evaluate each expression */
393 for (list = cdr(list); consp(list); list = cdr(list))
394 val = xleval(car(list));
395
396 /* exit the loop */
397 break;
398 }
399 }
400
401 /* return the value */
402 return (val);
403 }
404
405 /* xwhen - special form 'when' */
xwhen(void)406 LVAL xwhen(void)
407 {
408 LVAL val;
409
410 /* check the test expression */
411 if ((val = xleval(xlgetarg())))
412 while (moreargs())
413 val = xleval(nextarg());
414
415 /* return the value */
416 return (val);
417 }
418
419 /* xunless - special form 'unless' */
xunless(void)420 LVAL xunless(void)
421 {
422 LVAL val=NIL;
423
424 /* check the test expression */
425 if (xleval(xlgetarg()) == NIL)
426 while (moreargs())
427 val = xleval(nextarg());
428
429 /* return the value */
430 return (val);
431 }
432
433 /* xcase - special form 'case' */
xcase(void)434 LVAL xcase(void)
435 {
436 LVAL key,list,cases,val;
437
438 /* protect some pointers */
439 xlsave1(key);
440
441 /* get the key expression */
442 key = xleval(nextarg());
443
444 /* find a case that matches */
445 for (val = NIL; moreargs(); ) {
446
447 /* get the next case clause */
448 list = nextarg();
449
450 /* make sure this is a valid clause */
451 if (consp(list)) {
452
453 /* compare the key list against the key */
454 if ((cases = car(list)) == s_true ||
455 (listp(cases) && keypresent(key,cases)) ||
456 eql(key,cases)) {
457
458 /* evaluate each expression */
459 for (list = cdr(list); consp(list); list = cdr(list))
460 val = xleval(car(list));
461
462 /* exit the loop */
463 break;
464 }
465 }
466 else
467 xlerror("bad case clause",list);
468 }
469
470 /* restore the stack */
471 xlpop();
472
473 /* return the value */
474 return (val);
475 }
476
477 /* keypresent - check for the presence of a key in a list */
keypresent(LVAL key,LVAL list)478 LOCAL int keypresent(LVAL key, LVAL list)
479 {
480 for (; consp(list); list = cdr(list))
481 if (eql(car(list),key))
482 return (TRUE);
483 return (FALSE);
484 }
485
486 /* xand - special form 'and' */
xand(void)487 LVAL xand(void)
488 {
489 LVAL val;
490
491 /* evaluate each argument */
492 for (val = s_true; moreargs(); )
493 if ((val = xleval(nextarg())) == NIL)
494 break;
495
496 /* return the result value */
497 return (val);
498 }
499
500 /* x_or - special form 'or' */
501 /* this was named xor, but that caused problems with c++ under gcc */
x_or(void)502 LVAL x_or(void)
503 {
504 LVAL val;
505
506 /* evaluate each argument */
507 for (val = NIL; moreargs(); )
508 if ((val = xleval(nextarg())))
509 break;
510
511 /* return the result value */
512 return (val);
513 }
514
515 /* xif - special form 'if' */
xif(void)516 LVAL xif(void)
517 {
518 LVAL testexpr,thenexpr,elseexpr;
519
520 /* get the test expression, then clause and else clause */
521 testexpr = xlgetarg();
522 thenexpr = xlgetarg();
523 elseexpr = (moreargs() ? xlgetarg() : NIL);
524 xllastarg();
525
526 /* evaluate the appropriate clause */
527 return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
528 }
529
530 /* xlet - special form 'let' */
xlet(void)531 LVAL xlet(void)
532 {
533 return (let(TRUE));
534 }
535
536 /* xletstar - special form 'let*' */
xletstar(void)537 LVAL xletstar(void)
538 {
539 return (let(FALSE));
540 }
541
542 /* let - common let routine */
let(int pflag)543 LOCAL LVAL let(int pflag)
544 {
545 LVAL newenv,val;
546
547 /* protect some pointers */
548 xlsave1(newenv);
549
550 /* create a new environment frame */
551 newenv = xlframe(xlenv);
552
553 /* get the list of bindings and bind the symbols */
554 if (!pflag) {
555 xlenv = newenv;
556 }
557 dobindings(xlgalist(),newenv);
558 if (pflag) {
559 xlenv = newenv;
560 }
561
562 /* execute the code */
563 for (val = NIL; moreargs(); )
564 val = xleval(nextarg());
565
566 /* unbind the arguments */
567 xlenv = cdr(xlenv);
568
569 /* restore the stack */
570 xlpop();
571
572 /* return the result */
573 return (val);
574 }
575
576 /* xflet - built-in function 'flet' */
xflet(void)577 LVAL xflet(void)
578 {
579 return (flet(s_lambda,TRUE));
580 }
581
582 /* xlabels - built-in function 'labels' */
xlabels(void)583 LVAL xlabels(void)
584 {
585 return (flet(s_lambda,FALSE));
586 }
587
588 /* xmacrolet - built-in function 'macrolet' */
xmacrolet(void)589 LVAL xmacrolet(void)
590 {
591 return (flet(s_macro,TRUE));
592 }
593
594 /* flet - common flet/labels/macrolet routine */
flet(LVAL type,int letflag)595 LOCAL LVAL flet(LVAL type, int letflag)
596 {
597 LVAL list,bnd,sym,fargs,val;
598
599 /* create a new environment frame */
600 xlfenv = xlframe(xlfenv);
601
602 /* bind each symbol in the list of bindings */
603 for (list = xlgalist(); consp(list); list = cdr(list)) {
604
605 /* get the next binding */
606 bnd = car(list);
607
608 /* get the symbol and the function definition */
609 sym = match(SYMBOL,&bnd);
610 fargs = match(LIST,&bnd);
611 val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
612
613 /* bind the value to the symbol */
614 xlfbind(sym,val);
615 }
616
617 /* execute the code */
618 for (val = NIL; moreargs(); )
619 val = xleval(nextarg());
620
621 /* unbind the arguments */
622 xlfenv = cdr(xlfenv);
623
624 /* return the result */
625 return (val);
626 }
627
628 /* xprog - special form 'prog' */
xprog(void)629 LVAL xprog(void)
630 {
631 return (prog(TRUE));
632 }
633
634 /* xprogstar - special form 'prog*' */
xprogstar(void)635 LVAL xprogstar(void)
636 {
637 return (prog(FALSE));
638 }
639
640 /* prog - common prog routine */
prog(int pflag)641 LOCAL LVAL prog(int pflag)
642 {
643 LVAL newenv,val;
644 XLCONTEXT cntxt;
645
646 /* protect some pointers */
647 xlsave1(newenv);
648
649 /* create a new environment frame */
650 newenv = xlframe(xlenv);
651
652 /* establish a new execution context */
653 xlbegin(&cntxt,CF_RETURN,NIL);
654 if (_setjmp(cntxt.c_jmpbuf))
655 val = xlvalue;
656 else {
657
658 /* get the list of bindings and bind the symbols */
659 if (!pflag) {
660 xlenv = newenv;
661 }
662 dobindings(xlgalist(),newenv);
663 if (pflag) {
664 xlenv = newenv;
665 }
666
667 /* execute the code */
668 tagbody();
669 val = NIL;
670
671 /* unbind the arguments */
672 xlenv = cdr(xlenv);
673 }
674 xlend(&cntxt);
675
676 /* restore the stack */
677 xlpop();
678
679 /* return the result */
680 return (val);
681 }
682
683 /* 4035 is the "no return value" warning message */
684 /* xgo, xreturn, xrtnfrom, and xthrow don't return anything */
685 /* #pragma warning(disable: 4035) */
686 /* xgo - special form 'go' */
xgo(void)687 LVAL xgo(void)
688 {
689 LVAL label;
690
691 /* get the target label */
692 label = xlgetarg();
693 xllastarg();
694
695 /* transfer to the label */
696 xlgo(label);
697 return NIL; /* never happens */
698 }
699
700 /* xreturn - special form 'return' */
xreturn(void)701 LVAL xreturn(void)
702 {
703 LVAL val;
704
705 /* get the return value */
706 val = (moreargs() ? xleval(nextarg()) : NIL);
707 xllastarg();
708
709 /* return from the inner most block */
710 xlreturn(NIL,val);
711 return NIL; /* never happens */
712 }
713
714 /* xrtnfrom - special form 'return-from' */
xrtnfrom(void)715 LVAL xrtnfrom(void)
716 {
717 LVAL name,val;
718
719 /* get the return value */
720 name = xlgasymbol();
721 val = (moreargs() ? xleval(nextarg()) : NIL);
722 xllastarg();
723
724 /* return from the inner most block */
725 xlreturn(name,val);
726 return NIL; /* never happens */
727 }
728
729 /* xprog1 - special form 'prog1' */
xprog1(void)730 LVAL xprog1(void)
731 {
732 return (progx(1));
733 }
734
735 /* xprog2 - special form 'prog2' */
xprog2(void)736 LVAL xprog2(void)
737 {
738 return (progx(2));
739 }
740
741 /* progx - common progx code */
progx(int n)742 LOCAL LVAL progx(int n)
743 {
744 LVAL val;
745
746 /* protect some pointers */
747 xlsave1(val);
748
749 /* evaluate the first n expressions */
750 while (moreargs() && --n >= 0)
751 val = xleval(nextarg());
752
753 /* evaluate each remaining argument */
754 while (moreargs())
755 xleval(nextarg());
756
757 /* restore the stack */
758 xlpop();
759
760 /* return the last test expression value */
761 return (val);
762 }
763
764 /* xprogn - special form 'progn' */
xprogn(void)765 LVAL xprogn(void)
766 {
767 LVAL val;
768
769 /* evaluate each expression */
770 for (val = NIL; moreargs(); )
771 val = xleval(nextarg());
772
773 /* return the last test expression value */
774 return (val);
775 }
776
777 /* xprogv - special form 'progv' */
xprogv(void)778 LVAL xprogv(void)
779 {
780 LVAL olddenv,vars,vals,val;
781
782 /* protect some pointers */
783 xlstkcheck(2);
784 xlsave(vars);
785 xlsave(vals);
786
787 /* get the list of variables and the list of values */
788 vars = xlgetarg(); vars = xleval(vars);
789 vals = xlgetarg(); vals = xleval(vals);
790
791 /* bind the values to the variables */
792 for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
793 if (!symbolp(car(vars)))
794 xlerror("expecting a symbol",car(vars));
795 if (consp(vals)) {
796 xldbind(car(vars),car(vals));
797 vals = cdr(vals);
798 }
799 else
800 xldbind(car(vars),s_unbound);
801 }
802
803 /* evaluate each expression */
804 for (val = NIL; moreargs(); )
805 val = xleval(nextarg());
806
807 /* restore the previous environment and the stack */
808 xlunbind(olddenv);
809 xlpopn(2);
810
811 /* return the last test expression value */
812 return (val);
813 }
814
815 /* xloop - special form 'loop' */
xloop(void)816 LVAL xloop(void)
817 {
818 LVAL *argv,arg,val;
819 XLCONTEXT cntxt;
820 int argc;
821
822 /* protect some pointers */
823 xlsave1(arg);
824
825 /* establish a new execution context */
826 xlbegin(&cntxt,CF_RETURN,NIL);
827 if (_setjmp(cntxt.c_jmpbuf))
828 val = xlvalue;
829 else
830 for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
831 while (moreargs()) {
832 arg = nextarg();
833 if (consp(arg))
834 xleval(arg);
835 }
836 xlend(&cntxt);
837
838 /* restore the stack */
839 xlpop();
840
841 /* return the result */
842 return (val);
843 }
844
845 /* xdo - special form 'do' */
xdo(void)846 LVAL xdo(void)
847 {
848 return (doloop(TRUE));
849 }
850
851 /* xdostar - special form 'do*' */
xdostar(void)852 LVAL xdostar(void)
853 {
854 return (doloop(FALSE));
855 }
856
857 /* doloop - common do routine */
doloop(int pflag)858 LOCAL LVAL doloop(int pflag)
859 {
860 LVAL newenv,*argv,blist,clist,test,val;
861 XLCONTEXT cntxt;
862 int argc;
863
864 /* protect some pointers */
865 xlsave1(newenv);
866
867 /* get the list of bindings, the exit test and the result forms */
868 blist = xlgalist();
869 clist = xlgalist();
870 test = (consp(clist) ? car(clist) : NIL);
871 argv = xlargv;
872 argc = xlargc;
873
874 /* create a new environment frame */
875 newenv = xlframe(xlenv);
876
877 /* establish a new execution context */
878 xlbegin(&cntxt,CF_RETURN,NIL);
879 if (_setjmp(cntxt.c_jmpbuf))
880 val = xlvalue;
881 else {
882
883 /* bind the symbols */
884 if (!pflag) {
885 xlenv = newenv;
886 }
887 dobindings(blist,newenv);
888 if (pflag) {
889 xlenv = newenv;
890 }
891
892 /* execute the loop as long as the test is false */
893 for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
894 xlargv = argv;
895 xlargc = argc;
896 tagbody();
897 }
898
899 /* evaluate the result expression */
900 if (consp(clist))
901 for (clist = cdr(clist); consp(clist); clist = cdr(clist))
902 val = xleval(car(clist));
903
904 /* unbind the arguments */
905 xlenv = cdr(xlenv);
906 }
907 xlend(&cntxt);
908
909 /* restore the stack */
910 xlpop();
911
912 /* return the result */
913 return (val);
914 }
915
916 /* xdolist - special form 'dolist' */
xdolist(void)917 LVAL xdolist(void)
918 {
919 LVAL list,*argv,clist,sym,val;
920 XLCONTEXT cntxt;
921 int argc;
922
923 /* protect some pointers */
924 xlsave1(list);
925
926 /* get the control list (sym list result-expr) */
927 clist = xlgalist();
928 sym = match(SYMBOL,&clist);
929 list = evmatch(LIST,&clist);
930 argv = xlargv;
931 argc = xlargc;
932
933 /* initialize the local environment */
934 xlenv = xlframe(xlenv);
935 xlbind(sym,NIL);
936
937 /* establish a new execution context */
938 xlbegin(&cntxt,CF_RETURN,NIL);
939 if (_setjmp(cntxt.c_jmpbuf))
940 val = xlvalue;
941 else {
942
943 /* loop through the list */
944 for (val = NIL; consp(list); list = cdr(list)) {
945
946 /* bind the symbol to the next list element */
947 xlsetvalue(sym,car(list));
948
949 /* execute the loop body */
950 xlargv = argv;
951 xlargc = argc;
952 tagbody();
953 }
954
955 /* evaluate the result expression */
956 xlsetvalue(sym,NIL);
957 val = (consp(clist) ? xleval(car(clist)) : NIL);
958
959 /* unbind the arguments */
960 xlenv = cdr(xlenv);
961 }
962 xlend(&cntxt);
963
964 /* restore the stack */
965 xlpop();
966
967 /* return the result */
968 return (val);
969 }
970
971 /* xdotimes - special form 'dotimes' */
xdotimes(void)972 LVAL xdotimes(void)
973 {
974 LVAL *argv,clist,sym,cnt,val;
975 XLCONTEXT cntxt;
976 int argc,n,i;
977
978 /* get the control list (sym list result-expr) */
979 clist = xlgalist();
980 sym = match(SYMBOL,&clist);
981 cnt = evmatch(FIXNUM,&clist); n = (int) getfixnum(cnt);
982 argv = xlargv;
983 argc = xlargc;
984
985 /* establish a new execution context */
986 xlbegin(&cntxt,CF_RETURN,NIL);
987
988 /* initialize the local environment */
989 xlenv = xlframe(xlenv);
990 xlbind(sym,NIL);
991
992 if (_setjmp(cntxt.c_jmpbuf))
993 val = xlvalue;
994 else {
995
996 /* loop through for each value from zero to n-1 */
997 for (val = NIL, i = 0; i < n; ++i) {
998
999 /* bind the symbol to the next list element */
1000 xlsetvalue(sym,cvfixnum((FIXTYPE)i));
1001
1002 /* execute the loop body */
1003 xlargv = argv;
1004 xlargc = argc;
1005 tagbody();
1006 }
1007
1008 /* evaluate the result expression */
1009 xlsetvalue(sym,cnt);
1010 val = (consp(clist) ? xleval(car(clist)) : NIL);
1011
1012 /* unbind the arguments */
1013 xlenv = cdr(xlenv);
1014 }
1015 xlend(&cntxt);
1016
1017 /* return the result */
1018 return (val);
1019 }
1020
1021 /* xblock - special form 'block' */
xblock(void)1022 LVAL xblock(void)
1023 {
1024 LVAL name,val;
1025 XLCONTEXT cntxt;
1026
1027 /* get the block name */
1028 name = xlgetarg();
1029 if (name && !symbolp(name))
1030 xlbadtype(name);
1031
1032 /* execute the block */
1033 xlbegin(&cntxt,CF_RETURN,name);
1034 if (_setjmp(cntxt.c_jmpbuf))
1035 val = xlvalue;
1036 else
1037 for (val = NIL; moreargs(); )
1038 val = xleval(nextarg());
1039 xlend(&cntxt);
1040
1041 /* return the value of the last expression */
1042 return (val);
1043 }
1044
1045 /* xtagbody - special form 'tagbody' */
xtagbody(void)1046 LVAL xtagbody(void)
1047 {
1048 tagbody();
1049 return (NIL);
1050 }
1051
1052 /* xcatch - special form 'catch' */
xcatch(void)1053 LVAL xcatch(void)
1054 {
1055 XLCONTEXT cntxt;
1056 LVAL tag,val;
1057
1058 /* protect some pointers */
1059 xlsave1(tag);
1060
1061 /* get the tag */
1062 tag = xleval(nextarg());
1063
1064 /* establish an execution context */
1065 xlbegin(&cntxt,CF_THROW,tag);
1066
1067 /* check for 'throw' */
1068 if (_setjmp(cntxt.c_jmpbuf))
1069 val = xlvalue;
1070
1071 /* otherwise, evaluate the remainder of the arguments */
1072 else {
1073 for (val = NIL; moreargs(); )
1074 val = xleval(nextarg());
1075 }
1076 xlend(&cntxt);
1077
1078 /* restore the stack */
1079 xlpop();
1080
1081 /* return the result */
1082 return (val);
1083 }
1084
1085 /* xthrow - special form 'throw' */
xthrow(void)1086 LVAL xthrow(void)
1087 {
1088 LVAL tag,val;
1089
1090 /* get the tag and value */
1091 tag = xleval(nextarg());
1092 val = (moreargs() ? xleval(nextarg()) : NIL);
1093 xllastarg();
1094
1095 /* throw the tag */
1096 xlthrow(tag,val);
1097 return NIL; /* never happens */
1098 }
1099
1100 /* xunwindprotect - special form 'unwind-protect' */
xunwindprotect(void)1101 LVAL xunwindprotect(void)
1102 {
1103 extern XLCONTEXT *xltarget;
1104 extern int xlmask;
1105 XLCONTEXT cntxt;
1106 XLCONTEXT *target = NULL;
1107 int mask = 0;
1108 int sts;
1109 LVAL val;
1110
1111 /* protect some pointers */
1112 xlsave1(val);
1113
1114 /* get the expression to protect */
1115 val = xlgetarg();
1116
1117 /* evaluate the protected expression */
1118 xlbegin(&cntxt,CF_UNWIND,NIL);
1119 if ((sts = _setjmp(cntxt.c_jmpbuf))) {
1120 target = xltarget;
1121 mask = xlmask;
1122 val = xlvalue;
1123 }
1124 else
1125 val = xleval(val);
1126 xlend(&cntxt);
1127
1128 /* evaluate the cleanup expressions */
1129 while (moreargs())
1130 xleval(nextarg());
1131
1132 /* if unwinding, continue unwinding */
1133 if (sts)
1134 xljump(target,mask,val);
1135
1136 /* restore the stack */
1137 xlpop();
1138
1139 /* return the value of the protected expression */
1140 return (val);
1141 }
1142
1143 /* xerrset - special form 'errset' */
xerrset(void)1144 LVAL xerrset(void)
1145 {
1146 LVAL expr,flag,val;
1147 XLCONTEXT cntxt;
1148
1149 /* get the expression and the print flag */
1150 expr = xlgetarg();
1151 flag = (moreargs() ? xlgetarg() : s_true);
1152 xllastarg();
1153
1154 /* establish an execution context */
1155 xlbegin(&cntxt,CF_ERROR,flag);
1156
1157 /* check for error */
1158 if (_setjmp(cntxt.c_jmpbuf))
1159 val = NIL;
1160
1161 /* otherwise, evaluate the expression */
1162 else {
1163 expr = xleval(expr);
1164 val = consa(expr);
1165 }
1166 xlend(&cntxt);
1167
1168 /* return the result */
1169 return (val);
1170 }
1171
1172 /* xtrace - special form 'trace' */
xtrace(void)1173 LVAL xtrace(void)
1174 {
1175 LVAL sym,fun,this;
1176
1177 /* loop through all of the arguments */
1178 sym = xlenter("*TRACELIST*");
1179 while (moreargs()) {
1180 fun = xlgasymbol();
1181
1182 /* check for the function name already being in the list */
1183 for (this = getvalue(sym); consp(this); this = cdr(this))
1184 if (car(this) == fun)
1185 break;
1186
1187 /* add the function name to the list */
1188 if (null(this))
1189 setvalue(sym,cons(fun,getvalue(sym)));
1190 }
1191 return (getvalue(sym));
1192 }
1193
1194 /* xuntrace - special form 'untrace' */
xuntrace(void)1195 LVAL xuntrace(void)
1196 {
1197 LVAL sym,fun,this,last;
1198
1199 /* loop through all of the arguments */
1200 sym = xlenter("*TRACELIST*");
1201 while (moreargs()) {
1202 fun = xlgasymbol();
1203
1204 /* remove the function name from the list */
1205 last = NIL;
1206 for (this = getvalue(sym); consp(this); this = cdr(this)) {
1207 if (car(this) == fun) {
1208 if (last)
1209 rplacd(last,cdr(this));
1210 else
1211 setvalue(sym,cdr(this));
1212 break;
1213 }
1214 last = this;
1215 }
1216 }
1217 return (getvalue(sym));
1218 }
1219
1220 /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
dobindings(LVAL list,LVAL env)1221 LOCAL void dobindings(LVAL list, LVAL env)
1222 {
1223 LVAL bnd, val;
1224 LVAL sym = NULL;
1225
1226 /* protect some pointers */
1227 xlsave1(val);
1228
1229 /* bind each symbol in the list of bindings */
1230 for (; consp(list); list = cdr(list)) {
1231
1232 /* get the next binding */
1233 bnd = car(list);
1234
1235 /* handle a symbol */
1236 if (symbolp(bnd)) {
1237 sym = bnd;
1238 val = NIL;
1239 }
1240
1241 /* handle a list of the form (symbol expr) */
1242 else if (consp(bnd)) {
1243 sym = match(SYMBOL,&bnd);
1244 val = evarg(&bnd);
1245 }
1246 else
1247 xlfail("bad binding");
1248
1249 /* bind the value to the symbol */
1250 xlpbind(sym,val,env);
1251 }
1252
1253 /* restore the stack */
1254 xlpop();
1255 }
1256
1257 /* doupdates - handle updates for do/do* */
doupdates(LVAL list,int pflag)1258 LOCAL void doupdates(LVAL list, int pflag)
1259 {
1260 LVAL plist,bnd,sym,val;
1261
1262 /* protect some pointers */
1263 xlstkcheck(2);
1264 xlsave(plist);
1265 xlsave(val);
1266
1267 /* bind each symbol in the list of bindings */
1268 for (; consp(list); list = cdr(list)) {
1269
1270 /* get the next binding */
1271 bnd = car(list);
1272
1273 /* handle a list of the form (symbol expr) */
1274 if (consp(bnd)) {
1275 sym = match(SYMBOL,&bnd);
1276 bnd = cdr(bnd);
1277 if (bnd) {
1278 val = evarg(&bnd);
1279 if (pflag)
1280 plist = cons(cons(sym,val),plist);
1281 else
1282 xlsetvalue(sym,val);
1283 }
1284 }
1285 }
1286
1287 /* set the values for parallel updates */
1288 for (; plist; plist = cdr(plist))
1289 xlsetvalue(car(car(plist)),cdr(car(plist)));
1290
1291 /* restore the stack */
1292 xlpopn(2);
1293 }
1294
1295 /* tagbody - execute code within a block and tagbody */
tagbody(void)1296 LOCAL void tagbody(void)
1297 {
1298 LVAL *argv,arg;
1299 XLCONTEXT cntxt;
1300 int argc;
1301
1302 /* establish an execution context */
1303 xlbegin(&cntxt,CF_GO,NIL);
1304 argc = xlargc;
1305 argv = xlargv;
1306
1307 /* check for a 'go' */
1308 if (_setjmp(cntxt.c_jmpbuf)) {
1309 cntxt.c_xlargc = argc;
1310 cntxt.c_xlargv = argv;
1311 }
1312
1313 /* execute the body */
1314 while (moreargs()) {
1315 arg = nextarg();
1316 if (consp(arg))
1317 xleval(arg);
1318 }
1319 xlend(&cntxt);
1320 }
1321
1322 /* match - get an argument and match its type */
match(int type,LVAL * pargs)1323 LOCAL LVAL match(int type, LVAL *pargs)
1324 {
1325 LVAL arg;
1326
1327 /* make sure the argument exists */
1328 if (!consp(*pargs))
1329 toofew(*pargs);
1330
1331 /* get the argument value */
1332 arg = car(*pargs);
1333
1334 /* move the argument pointer ahead */
1335 *pargs = cdr(*pargs);
1336
1337 /* check its type */
1338 if (type == LIST) {
1339 if (arg && ntype(arg) != CONS)
1340 xlerror("bad argument type",arg);
1341 }
1342 else {
1343 if (arg == NIL || ntype(arg) != type)
1344 xlerror("bad argument type",arg);
1345 }
1346
1347 /* return the argument */
1348 return (arg);
1349 }
1350
1351 /* evarg - get the next argument and evaluate it */
evarg(LVAL * pargs)1352 LOCAL LVAL evarg(LVAL *pargs)
1353 {
1354 LVAL arg;
1355
1356 /* protect some pointers */
1357 xlsave1(arg);
1358
1359 /* make sure the argument exists */
1360 if (!consp(*pargs))
1361 toofew(*pargs);
1362
1363 /* get the argument value */
1364 arg = car(*pargs);
1365
1366 /* move the argument pointer ahead */
1367 *pargs = cdr(*pargs);
1368
1369 /* evaluate the argument */
1370 arg = xleval(arg);
1371
1372 /* restore the stack */
1373 xlpop();
1374
1375 /* return the argument */
1376 return (arg);
1377 }
1378
1379 /* evmatch - get an evaluated argument and match its type */
evmatch(int type,LVAL * pargs)1380 LOCAL LVAL evmatch(int type, LVAL *pargs)
1381 {
1382 LVAL arg;
1383
1384 /* protect some pointers */
1385 xlsave1(arg);
1386
1387 /* make sure the argument exists */
1388 if (!consp(*pargs))
1389 toofew(*pargs);
1390
1391 /* get the argument value */
1392 arg = car(*pargs);
1393
1394 /* move the argument pointer ahead */
1395 *pargs = cdr(*pargs);
1396
1397 /* evaluate the argument */
1398 arg = xleval(arg);
1399
1400 /* check its type */
1401 if (type == LIST) {
1402 if (arg && ntype(arg) != CONS)
1403 xlerror("bad argument type",arg);
1404 }
1405 else {
1406 if (arg == NIL || ntype(arg) != type)
1407 xlerror("bad argument type",arg);
1408 }
1409
1410 /* restore the stack */
1411 xlpop();
1412
1413 /* return the argument */
1414 return (arg);
1415 }
1416
1417 /* toofew - too few arguments */
toofew(LVAL args)1418 LOCAL void toofew(LVAL args)
1419 {
1420 xlerror("too few arguments",args);
1421 }
1422
1423 /* toomany - too many arguments */
toomany(LVAL args)1424 LOCAL void toomany(LVAL args)
1425 {
1426 xlerror("too many arguments",args);
1427 }
1428
1429