1 /* xlbfun.c - xlisp basic built-in functions */
2 /* Copyright (c) 1985, by David Michael Betz
3 All Rights Reserved
4 Permission is granted for unrestricted non-commercial use */
5
6 #include "xlisp.h"
7 #include "string.h"
8
9 /* forward declarations */
10 FORWARD LOCAL LVAL makesymbol(int iflag);
11
12 /* xeval - the built-in function 'eval' */
xeval(void)13 LVAL xeval(void)
14 {
15 LVAL expr;
16
17 /* get the expression to evaluate */
18 expr = xlgetarg();
19 xllastarg();
20
21 /* evaluate the expression */
22 return (xleval(expr));
23 }
24
25 /* xapply - the built-in function 'apply' */
xapply(void)26 LVAL xapply(void)
27 {
28 LVAL fun,arglist;
29
30 /* get the function and argument list */
31 fun = xlgetarg();
32 arglist = xlgalist();
33 xllastarg();
34
35 /* apply the function to the arguments */
36 return (xlapply(pushargs(fun,arglist)));
37 }
38
39 /* xfuncall - the built-in function 'funcall' */
xfuncall(void)40 LVAL xfuncall(void)
41 {
42 LVAL *newfp;
43 int argc;
44
45 /* build a new argument stack frame */
46 newfp = xlsp;
47 pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
48 pusharg(xlgetarg());
49 pusharg(NIL); /* will be argc */
50
51 /* push each argument */
52 for (argc = 0; moreargs(); ++argc)
53 pusharg(nextarg());
54
55 /* establish the new stack frame */
56 newfp[2] = cvfixnum((FIXTYPE)argc);
57 xlfp = newfp;
58
59 /* apply the function to the arguments */
60 return (xlapply(argc));
61 }
62
63 /* xmacroexpand - expand a macro call repeatedly */
xmacroexpand(void)64 LVAL xmacroexpand(void)
65 {
66 LVAL form;
67 form = xlgetarg();
68 xllastarg();
69 return (xlexpandmacros(form));
70 }
71
72 /* x1macroexpand - expand a macro call */
x1macroexpand(void)73 LVAL x1macroexpand(void)
74 {
75 LVAL form,fun,args;
76
77 /* protect some pointers */
78 xlstkcheck(2);
79 xlsave(fun);
80 xlsave(args);
81
82 /* get the form */
83 form = xlgetarg();
84 xllastarg();
85
86 /* expand until the form isn't a macro call */
87 if (consp(form)) {
88 fun = car(form); /* get the macro name */
89 args = cdr(form); /* get the arguments */
90 if (symbolp(fun) && fboundp(fun)) {
91 fun = xlgetfunction(fun); /* get the expansion function */
92 macroexpand(fun,args,&form);
93 }
94 }
95
96 /* restore the stack and return the expansion */
97 xlpopn(2);
98 return (form);
99 }
100
101 /* xatom - is this an atom? */
xatom(void)102 LVAL xatom(void)
103 {
104 LVAL arg;
105 arg = xlgetarg();
106 xllastarg();
107 return (atomp(arg) ? s_true : NIL);
108 }
109
110 /* xsymbolp - is this an symbol? */
xsymbolp(void)111 LVAL xsymbolp(void)
112 {
113 LVAL arg;
114 arg = xlgetarg();
115 xllastarg();
116 return (arg == NIL || symbolp(arg) ? s_true : NIL);
117 }
118
119 /* xnumberp - is this a number? */
xnumberp(void)120 LVAL xnumberp(void)
121 {
122 LVAL arg;
123 arg = xlgetarg();
124 xllastarg();
125 return (fixp(arg) || floatp(arg) ? s_true : NIL);
126 }
127
128 /* xintegerp - is this an integer? */
xintegerp(void)129 LVAL xintegerp(void)
130 {
131 LVAL arg;
132 arg = xlgetarg();
133 xllastarg();
134 return (fixp(arg) ? s_true : NIL);
135 }
136
137 /* xfloatp - is this a float? */
xfloatp(void)138 LVAL xfloatp(void)
139 {
140 LVAL arg;
141 arg = xlgetarg();
142 xllastarg();
143 return (floatp(arg) ? s_true : NIL);
144 }
145
146 /* xcharp - is this a character? */
xcharp(void)147 LVAL xcharp(void)
148 {
149 LVAL arg;
150 arg = xlgetarg();
151 xllastarg();
152 return (charp(arg) ? s_true : NIL);
153 }
154
155 /* xstringp - is this a string? */
xstringp(void)156 LVAL xstringp(void)
157 {
158 LVAL arg;
159 arg = xlgetarg();
160 xllastarg();
161 return (stringp(arg) ? s_true : NIL);
162 }
163
164 /* xarrayp - is this an array? */
xarrayp(void)165 LVAL xarrayp(void)
166 {
167 LVAL arg;
168 arg = xlgetarg();
169 xllastarg();
170 return (vectorp(arg) ? s_true : NIL);
171 }
172
173 /* xstreamp - is this a stream? */
xstreamp(void)174 LVAL xstreamp(void)
175 {
176 LVAL arg;
177 arg = xlgetarg();
178 xllastarg();
179 return (streamp(arg) || ustreamp(arg) ? s_true : NIL);
180 }
181
182 /* xobjectp - is this an object? */
xobjectp(void)183 LVAL xobjectp(void)
184 {
185 LVAL arg;
186 arg = xlgetarg();
187 xllastarg();
188 return (objectp(arg) ? s_true : NIL);
189 }
190
191 /* xboundp - is this a value bound to this symbol? */
xboundp(void)192 LVAL xboundp(void)
193 {
194 LVAL sym;
195 sym = xlgasymbol();
196 xllastarg();
197 return (boundp(sym) ? s_true : NIL);
198 }
199
200 /* xfboundp - is this a functional value bound to this symbol? */
xfboundp(void)201 LVAL xfboundp(void)
202 {
203 LVAL sym;
204 sym = xlgasymbol();
205 xllastarg();
206 return (fboundp(sym) ? s_true : NIL);
207 }
208
209 /* xnull - is this null? */
xnull(void)210 LVAL xnull(void)
211 {
212 LVAL arg;
213 arg = xlgetarg();
214 xllastarg();
215 return (null(arg) ? s_true : NIL);
216 }
217
218 /* xlistp - is this a list? */
xlistp(void)219 LVAL xlistp(void)
220 {
221 LVAL arg;
222 arg = xlgetarg();
223 xllastarg();
224 return (listp(arg) ? s_true : NIL);
225 }
226
227 /* xendp - is this the end of a list? */
xendp(void)228 LVAL xendp(void)
229 {
230 LVAL arg;
231 arg = xlgalist();
232 xllastarg();
233 return (null(arg) ? s_true : NIL);
234 }
235
236 /* xconsp - is this a cons? */
xconsp(void)237 LVAL xconsp(void)
238 {
239 LVAL arg;
240 arg = xlgetarg();
241 xllastarg();
242 return (consp(arg) ? s_true : NIL);
243 }
244
245 /* xeq - are these equal? */
xeq(void)246 LVAL xeq(void)
247 {
248 LVAL arg1,arg2;
249
250 /* get the two arguments */
251 arg1 = xlgetarg();
252 arg2 = xlgetarg();
253 xllastarg();
254
255 /* compare the arguments */
256 return (arg1 == arg2 ? s_true : NIL);
257 }
258
259 /* xeql - are these equal? */
xeql(void)260 LVAL xeql(void)
261 {
262 LVAL arg1,arg2;
263
264 /* get the two arguments */
265 arg1 = xlgetarg();
266 arg2 = xlgetarg();
267 xllastarg();
268
269 /* compare the arguments */
270 return (eql(arg1,arg2) ? s_true : NIL);
271 }
272
273 /* xequal - are these equal? (recursive) */
xequal(void)274 LVAL xequal(void)
275 {
276 LVAL arg1,arg2;
277
278 /* get the two arguments */
279 arg1 = xlgetarg();
280 arg2 = xlgetarg();
281 xllastarg();
282
283 /* compare the arguments */
284 return (lval_equal(arg1,arg2) ? s_true : NIL);
285 }
286
287 /* xset - built-in function set */
xset(void)288 LVAL xset(void)
289 {
290 LVAL sym,val;
291
292 /* get the symbol and new value */
293 sym = xlgasymbol();
294 val = xlgetarg();
295 xllastarg();
296
297 /* assign the symbol the value of argument 2 and the return value */
298 setvalue(sym,val);
299
300 /* return the result value */
301 return (val);
302 }
303
304 /* xgensym - generate a symbol */
xgensym(void)305 LVAL xgensym(void)
306 {
307 char sym[STRMAX+11]; /* enough space for prefix and number */
308 LVAL x;
309
310 /* get the prefix or number */
311 if (moreargs()) {
312 x = xlgetarg();
313 switch (ntype(x)) {
314 case SYMBOL:
315 x = getpname(x);
316 case STRING:
317 strncpy(gsprefix, (char *) getstring(x),STRMAX);
318 gsprefix[STRMAX] = '\0';
319 break;
320 case FIXNUM:
321 gsnumber = (int) getfixnum(x);
322 break;
323 default:
324 xlerror("bad argument type",x);
325 }
326 }
327 xllastarg();
328
329 /* create the pname of the new symbol */
330 sprintf(sym,"%s%d",gsprefix,gsnumber++);
331
332 /* make a symbol with this print name */
333 return (xlmakesym(sym));
334 }
335
336 /* xmakesymbol - make a new uninterned symbol */
xmakesymbol(void)337 LVAL xmakesymbol(void)
338 {
339 return (makesymbol(FALSE));
340 }
341
342 /* xintern - make a new interned symbol */
xintern(void)343 LVAL xintern(void)
344 {
345 return (makesymbol(TRUE));
346 }
347
348 /* makesymbol - make a new symbol */
makesymbol(int iflag)349 LOCAL LVAL makesymbol(int iflag)
350 {
351 LVAL pname;
352
353 /* get the print name of the symbol to intern */
354 pname = xlgastring();
355 xllastarg();
356
357 /* make the symbol */
358 return (iflag ? xlenter((char *) getstring(pname))
359 : xlmakesym((char *) getstring(pname)));
360 }
361
362 /* xsymname - get the print name of a symbol */
xsymname(void)363 LVAL xsymname(void)
364 {
365 LVAL sym;
366
367 /* get the symbol */
368 sym = xlgasymbol();
369 xllastarg();
370
371 /* return the print name */
372 return (getpname(sym));
373 }
374
375 /* xsymvalue - get the value of a symbol */
xsymvalue(void)376 LVAL xsymvalue(void)
377 {
378 LVAL sym,val;
379
380 /* get the symbol */
381 sym = xlgasymbol();
382 xllastarg();
383
384 /* get the global value */
385 while ((val = getvalue(sym)) == s_unbound)
386 xlunbound(sym);
387
388 /* return its value */
389 return (val);
390 }
391
392 /* xsymfunction - get the functional value of a symbol */
xsymfunction(void)393 LVAL xsymfunction(void)
394 {
395 LVAL sym,val;
396
397 /* get the symbol */
398 sym = xlgasymbol();
399 xllastarg();
400
401 /* get the global value */
402 while ((val = getfunction(sym)) == s_unbound)
403 xlfunbound(sym);
404
405 /* return its value */
406 return (val);
407 }
408
409 /* xsymplist - get the property list of a symbol */
xsymplist(void)410 LVAL xsymplist(void)
411 {
412 LVAL sym;
413
414 /* get the symbol */
415 sym = xlgasymbol();
416 xllastarg();
417
418 /* return the property list */
419 return (getplist(sym));
420 }
421
422 /* xget - get the value of a property */
xget(void)423 LVAL xget(void)
424 {
425 LVAL sym,prp;
426
427 /* get the symbol and property */
428 sym = xlgasymbol();
429 prp = xlgasymbol();
430 xllastarg();
431
432 /* retrieve the property value */
433 return (xlgetprop(sym,prp));
434 }
435
436 /* xputprop - set the value of a property */
xputprop(void)437 LVAL xputprop(void)
438 {
439 LVAL sym,val,prp;
440
441 /* get the symbol and property */
442 sym = xlgasymbol();
443 val = xlgetarg();
444 prp = xlgasymbol();
445 xllastarg();
446
447 /* set the property value */
448 xlputprop(sym,val,prp);
449
450 /* return the value */
451 return (val);
452 }
453
454 /* xremprop - remove a property value from a property list */
xremprop(void)455 LVAL xremprop(void)
456 {
457 LVAL sym,prp;
458
459 /* get the symbol and property */
460 sym = xlgasymbol();
461 prp = xlgasymbol();
462 xllastarg();
463
464 /* remove the property */
465 xlremprop(sym,prp);
466
467 /* return nil */
468 return (NIL);
469 }
470
471 /* xhash - compute the hash value of a string or symbol */
xhash(void)472 LVAL xhash(void)
473 {
474 unsigned char *str;
475 LVAL len,val;
476 int n;
477
478 /* get the string and the table length */
479 val = xlgetarg();
480 len = xlgafixnum(); n = (int)getfixnum(len);
481 xllastarg();
482
483 /* get the string */
484 if (symbolp(val))
485 str = getstring(getpname(val));
486 else if (stringp(val))
487 str = getstring(val);
488 else {
489 xlerror("bad argument type",val);
490 str = NULL;
491 }
492
493 /* return the hash index */
494 return (cvfixnum((FIXTYPE)hash((char *) str, n)));
495 }
496
497 /* xaref - array reference function */
xaref(void)498 LVAL xaref(void)
499 {
500 LVAL array,index;
501 int i;
502
503 /* get the array and the index */
504 array = xlgavector();
505 index = xlgafixnum(); i = (int)getfixnum(index);
506 xllastarg();
507
508 /* range check the index */
509 if (i < 0 || i >= getsize(array))
510 xlerror("array index out of bounds",index);
511
512 /* return the array element */
513 return (getelement(array,i));
514 }
515
516 /* xmkarray - make a new array */
xmkarray(void)517 LVAL xmkarray(void)
518 {
519 LVAL size;
520 int n;
521
522 /* get the size of the array */
523 size = xlgafixnum() ; n = (int)getfixnum(size);
524 xllastarg();
525
526 /* create the array */
527 return (newvector(n));
528 }
529
530 /* xvector - make a vector */
xvector(void)531 LVAL xvector(void)
532 {
533 LVAL val;
534 int i;
535
536 /* make the vector */
537 val = newvector(xlargc);
538
539 /* store each argument */
540 for (i = 0; moreargs(); ++i)
541 setelement(val,i,nextarg());
542 xllastarg();
543
544 /* return the vector */
545 return (val);
546 }
547
548
549 /* xerror - special form 'error' */
xerror(void)550 LVAL xerror(void)
551 {
552 LVAL emsg,arg;
553
554 /* get the error message and the argument */
555 emsg = xlgastring();
556 arg = (moreargs() ? xlgetarg() : s_unbound);
557 xllastarg();
558
559 /* signal the error */
560 xlerror((char *) getstring(emsg),arg);
561 return NIL; /* won't ever happen */
562 }
563
564 /* xcerror - special form 'cerror' */
xcerror(void)565 LVAL xcerror(void)
566 {
567 LVAL cmsg,emsg,arg;
568
569 /* get the correction message, the error message, and the argument */
570 cmsg = xlgastring();
571 emsg = xlgastring();
572 arg = (moreargs() ? xlgetarg() : s_unbound);
573 xllastarg();
574
575 /* signal the error */
576 xlcerror((char *) getstring(cmsg), (char *) getstring(emsg),arg);
577
578 /* return nil */
579 return (NIL);
580 }
581
582 /* xbreak - special form 'break' */
xbreak(void)583 LVAL xbreak(void)
584 {
585 LVAL emsg,arg;
586
587 /* get the error message */
588 emsg = (moreargs() ? xlgastring() : NIL);
589 arg = (moreargs() ? xlgetarg() : s_unbound);
590 xllastarg();
591
592 /* enter the break loop */
593 xlbreak((emsg ? (char *) getstring(emsg) : "**BREAK**"),arg);
594
595 /* return nil */
596 return (NIL);
597 }
598
599 #pragma warning(disable: 4716 4068) // return type and unknown pragma
600 #pragma clang diagnostic ignored "-Wreturn-type"
601 /* xcleanup - special form 'clean-up' */
xcleanup(void)602 LVAL xcleanup(void)
603 {
604 xllastarg();
605 xlcleanup();
606 /* compiler might (wrongly) complain there is no return value */
607 }
608
609 /* xtoplevel - special form 'top-level' */
xtoplevel(void)610 LVAL xtoplevel(void)
611 {
612 xllastarg();
613 xltoplevel();
614 /* this point will never be reached because xltoplevel() does a
615 _longjmp(). The return is added to avoid false positive
616 error messages from static analyzers and compilers */
617 return (NIL);
618 }
619
620 /* xcontinue - special form 'continue' */
xcontinue(void)621 LVAL xcontinue(void)
622 {
623 xllastarg();
624 xlcontinue();
625 return (NIL);
626 }
627
628 /* xevalhook - eval hook function */
xevalhook(void)629 LVAL xevalhook(void)
630 {
631 LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
632
633 /* protect some pointers */
634 xlstkcheck(3);
635 xlsave(oldenv);
636 xlsave(oldfenv);
637 xlsave(newenv);
638
639 /* get the expression, the new hook functions and the environment */
640 expr = xlgetarg();
641 newehook = xlgetarg();
642 newahook = xlgetarg();
643 newenv = (moreargs() ? xlgalist() : NIL);
644 xllastarg();
645
646 /* bind *evalhook* and *applyhook* to the hook functions */
647 olddenv = xldenv;
648 xldbind(s_evalhook,newehook);
649 xldbind(s_applyhook,newahook);
650
651 /* establish the environment for the hook function */
652 if (newenv) {
653 oldenv = xlenv;
654 oldfenv = xlfenv;
655 xlenv = car(newenv);
656 xlfenv = cdr(newenv);
657 }
658
659 /* evaluate the expression (bypassing *evalhook*) */
660 val = xlxeval(expr);
661
662 /* restore the old environment */
663 xlunbind(olddenv);
664 if (newenv) {
665 xlenv = oldenv;
666 xlfenv = oldfenv;
667 }
668
669 /* restore the stack */
670 xlpopn(3);
671
672 /* return the result */
673 return (val);
674 }
675
676