1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <math.h>
4 #ifdef __arm__
5 #include <wiringPi.h>
6 #include <wiringPiSPI.h>
7 #endif
8 #include "eisl.h"
9
10 void
initexsubr(void)11 initexsubr(void)
12 {
13 defsubr("RANDOM-REAL", f_random_real);
14 defsubr("RANDOM", f_random);
15 defsubr("NCONC", f_nconc);
16 defsubr("FAST-ADDRESS", f_address);
17 defsubr("MACROEXPAND-1", f_macroexpand_1);
18 defsubr("MACROEXPAND-ALL", f_macroexpand_all);
19 defsubr("BACKTRACE", f_backtrace);
20 defsubr("BREAK", f_break);
21 defsubr("EDIT", f_edit);
22 defsubr("FREEDLL", f_freedll);
23 defsubr("SYSTEM", f_system);
24 defsubr("SUBRP", f_subrp);
25 defsubr("MACROP", f_macrop);
26 defsubr("FIXNUMP", f_fixnump);
27 defsubr("LONGNUMP", f_longnump);
28 defsubr("BIGNUMP", f_bignump);
29 defsubr("SELF-INTRODUCTION", f_self_introduction);
30 defsubr("CLASSP", f_classp);
31 defsubr("C-INCLUDE", f_ignore);
32 defsubr("C-DEFINE", f_ignore);
33 defsubr("C-LANG", f_ignore);
34 defsubr("C-OPTION", f_ignore);
35 defsubr("HEAPDUMP", f_heapdump);
36 defsubr("INSTANCE", f_instance);
37 defsubr("LINE-ARGUMENT", f_line_argument);
38 defsubr("GETENV", f_getenv);
39 defsubr("EISL-MODULESUBST", f_modulesubst);
40 defsubr("EISL-SUPERP-FOR-COMPILER", f_superp_for_compiler);
41 defsubr("EISL-READED-ARRAY-LIST", f_readed_array_list);
42 defsubr("EISL-GET-METHOD", f_get_method);
43 defsubr("EISL-GET-METHOD-BODY", f_get_method_body);
44 defsubr("EISL-GET-METHOD-PRIORITY", f_get_method_priority);
45 defsubr("EISL-IGNORE-TOPLEVEL-CHECK", f_ignore_toplevel_check);
46
47 #ifdef __arm__
48 defsubr("WIRINGPI-SETUP-GPIO", f_wiringpi_setup_gpio);
49 defsubr("WIRINGPI-SPI-SETUP-CH-SPEED", f_wiringpi_spi_setup_ch_speed);
50 defsubr("PWM-SET-MODE", f_pwm_set_mode);
51 defsubr("PWM-SET-RANGE", f_pwm_set_range);
52 defsubr("PWM-SET-CLOCK", f_pwm_set_clock);
53 defsubr("PIN-MODE", f_pin_mode);
54 defsubr("DIGITAL-WRITE", f_digital_write);
55 defsubr("DIGITAL-WRITE-BYTE", f_digital_write_byte);
56 defsubr("PULL-UP-DN-CONTROL", f_pull_up_dn_control);
57 defsubr("DIGITAL-READ", f_digital_read);
58 defsubr("DELAY", f_delay);
59 defsubr("DELAY-MICROSECONDS", f_delay_microseconds);
60 #endif
61
62 }
63
64 // Fast Project
65 int
f_classp(int arglist)66 f_classp(int arglist)
67 {
68 int arg1;
69
70 arg1 = car(arglist);
71 if (length(arglist) != 1)
72 error(ILLEGAL_ARGS, "classp", arglist);
73
74 if (IS_CLASS(arg1))
75 return (T);
76 else
77 return (NIL);
78 }
79
80
81 int
f_ignore(int arglist __unused)82 f_ignore(int arglist __unused)
83 {
84 return (T);
85 }
86
87
88 int
f_self_introduction(int arglist __unused)89 f_self_introduction(int arglist __unused)
90 {
91 #if __APPLE__
92 return (makesym("MACOS"));
93 #elif defined(__OpenBSD__)
94 return (makesym("OPENBSD"));
95 #else
96 return (makesym("LINUX"));
97 #endif
98 }
99
100
101 int
f_ignore_toplevel_check(int arglist)102 f_ignore_toplevel_check(int arglist)
103 {
104 int arg1;
105
106 arg1 = car(arglist);
107 if (arg1 == T)
108 ignore_topchk = true;
109 else
110 ignore_topchk = false;
111 return (T);
112 }
113
DEF_PREDICATE(METHOD,METHOD)114 DEF_PREDICATE(METHOD, METHOD)
115 int f_get_method_priority(int arglist)
116 {
117 int arg1;
118
119 arg1 = car(arglist);
120 if (!(IS_METHOD(arg1)))
121 error(ILLEGAL_ARGS, "eisl-get-method-priority", arg1);
122
123 return (makeint(GET_OPT(arg1) + 1));
124 /*
125 * 11=:around 12=:befor 13=:primary 14=:arter
126 */
127 }
128
129
130 int
f_get_method_body(int arglist)131 f_get_method_body(int arglist)
132 {
133 int arg1;
134
135 arg1 = car(arglist);
136 if (!(IS_METHOD(arg1)))
137 error(ILLEGAL_ARGS, "get-method-body", arg1);
138
139 return (GET_CAR(arg1));
140 }
141
142 int
f_get_method(int arglist)143 f_get_method(int arglist)
144 {
145 int arg1;
146
147 arg1 = car(arglist);
148 if (!genericp(arg1))
149 error(ILLEGAL_ARGS, "get-method", arg1);
150
151 return (GET_CDR(GET_CAR(arg1)));
152 }
153
154
155 int
f_readed_array_list(int arglist)156 f_readed_array_list(int arglist)
157 {
158 int arg1;
159
160 arg1 = car(arglist);
161 return (GET_PROP(arg1));
162 }
163
164
165 int
f_system(int arglist)166 f_system(int arglist)
167 {
168 int arg1;
169
170 arg1 = car(arglist);
171 if (system(GET_NAME(arg1)) == -1)
172 error(SYSTEM_ERR, "system", arg1);
173 return (T);
174 }
175
176
177
178 int
f_freedll(int arglist __unused)179 f_freedll(int arglist __unused)
180 {
181 // dlclose(hmod);
182 return (T);
183 }
184
185
186
187 int
f_macrop(int arglist)188 f_macrop(int arglist)
189 {
190 int arg1;
191
192 arg1 = car(arglist);
193 if (length(arglist) != 1)
194 error(WRONG_ARGS, "macrop", arglist);
195 if (IS_MACRO(GET_CAR(arg1)))
196 return (T);
197 else
198 return (NIL);
199 }
200
201 int
f_fixnump(int arglist)202 f_fixnump(int arglist)
203 {
204 int arg1;
205
206 arg1 = car(arglist);
207 if (length(arglist) != 1)
208 error(WRONG_ARGS, "fixnump", arglist);
209 if (IS_INTEGER(arg1))
210 return (T);
211 else
212 return (NIL);
213 }
214
215 int
f_longnump(int arglist)216 f_longnump(int arglist)
217 {
218 int arg1;
219
220 arg1 = car(arglist);
221 if (length(arglist) != 1)
222 error(WRONG_ARGS, "longnump", arglist);
223 if (IS_LONGNUM(arg1))
224 return (T);
225 else
226 return (NIL);
227 }
228
229 int
f_bignump(int arglist)230 f_bignump(int arglist)
231 {
232 int arg1;
233
234 arg1 = car(arglist);
235 if (length(arglist) != 1)
236 error(WRONG_ARGS, "bignump", arglist);
237 if (IS_BIGXNUM(arg1))
238 return (T);
239 else
240 return (NIL);
241 }
242
243
244 int
f_subrp(int arglist)245 f_subrp(int arglist)
246 {
247 int arg;
248
249 arg = car(arglist);
250 if (length(arglist) != 1)
251 error(WRONG_ARGS, "subrp", arglist);
252 if (IS_SUBR(GET_CAR(arg)))
253 return (T);
254 else
255 return (NIL);
256 }
257
258 int
f_random_real(int arglist)259 f_random_real(int arglist)
260 {
261 double d;
262
263 if (length(arglist) != 0)
264 error(WRONG_ARGS, "random-real", arglist);
265
266 d = (double) rand() / RAND_MAX;
267 return (makeflt(d));
268 }
269
270 int
f_random(int arglist)271 f_random(int arglist)
272 {
273 int arg1,
274 n;
275
276 if (length(arglist) != 1)
277 error(WRONG_ARGS, "random", arglist);
278
279 arg1 = car(arglist);
280 n = GET_INT(arg1);
281
282 return (makeint(rand() % n));
283 }
284
285 int
f_nconc(int arglist)286 f_nconc(int arglist)
287 {
288 int arg1,
289 arg2;
290
291 arg1 = car(arglist);
292 arg2 = cadr(arglist);
293 if (length(arglist) != 2)
294 error(WRONG_ARGS, "nconc", arglist);
295
296 return (nconc(arg1, arg2));
297 }
298
299 int
f_address(int arglist)300 f_address(int arglist)
301 {
302 int arg1;
303
304 arg1 = car(arglist);
305 if (length(arglist) != 1)
306 error(WRONG_ARGS, "address", arglist);
307
308 return (makeint(arg1));
309 }
310
311 int
f_macroexpand_1(int arglist)312 f_macroexpand_1(int arglist)
313 {
314 int arg1,
315 args;
316
317 arg1 = caar(arglist);
318 args = cdar(arglist);
319 if (length(arglist) != 1)
320 error(WRONG_ARGS, "macroexpand-1", arglist);
321 if (!symbolp(arg1))
322 error(NOT_SYM, "macroexpand-1", arg1);
323
324 return (macroexpand_1(arg1, args));
325 }
326
327 int
macroexpand_1(int macsym,int args)328 macroexpand_1(int macsym, int args)
329 {
330 int func,
331 body,
332 macrofunc,
333 varlist,
334 save,
335 res;
336
337 func = GET_CAR(macsym);
338 save = ep;
339 res = NIL;
340 macrofunc = GET_CAR(func);
341 varlist = car(GET_CAR(macrofunc));
342 if (GET_OPT(func) >= 0) {
343 if (length(args) != (int) GET_OPT(func))
344 error(WRONG_ARGS, "macroexpand-1", args);
345 } else {
346 if (length(args) < (-1 * (int) GET_OPT(func) - 2))
347 error(WRONG_ARGS, "macroexpand-1", args);
348 }
349 body = cdr(GET_CAR(macrofunc));
350 bindarg(varlist, args);
351 while (!(IS_NIL(body))) {
352 res = eval(car(body));
353 body = cdr(body);
354 }
355 unbind();
356 ep = save;
357 return (res);
358 }
359
360 int
f_macroexpand_all(int arglist)361 f_macroexpand_all(int arglist)
362 {
363 int arg1;
364
365 arg1 = car(arglist);
366 if (length(arglist) != 1)
367 error(WRONG_ARGS, "macroexpand-all", arglist);
368 if (listp(arg1) && car(arg1) == makesym("DEFMACRO"))
369 return (arg1);
370 else
371 return (macroexpand_all(arg1));
372 }
373
374
375 int
macroexpand_all(int sexp)376 macroexpand_all(int sexp)
377 {
378
379 if (nullp(sexp))
380 return (NIL);
381 else if (atomp(sexp))
382 return (sexp);
383 else if (listp(sexp) && car(sexp) == makesym("QUOTE"))
384 return (sexp);
385 else if (listp(sexp) && macrop(car(sexp)))
386 return (macroexpand_all(macroexpand_1(car(sexp), cdr(sexp))));
387 else if (listp(sexp))
388 return (cons
389 (macroexpand_all(car(sexp)), macroexpand_all(cdr(sexp))));
390
391 return (NIL);
392 }
393
394 int
f_backtrace(int arglist)395 f_backtrace(int arglist)
396 {
397 int arg1,
398 l;
399
400 if ((l = length(arglist)) != 0 && l != 1)
401 error(WRONG_ARGS, "backtrace", arglist);
402
403 arg1 = car(arglist);
404
405 if (l == 0) {
406 int i;
407
408 for (i = 0; i < BACKSIZE; i++) {
409 print(backtrace[i]);
410 putchar('\n');
411 }
412 } else if (arg1 == T)
413 back_flag = true;
414 else if (arg1 == NIL)
415 back_flag = false;
416
417 return (T);
418 }
419
420 int
f_break(int arglist __unused)421 f_break(int arglist __unused)
422 {
423 puts("break");
424 debugger();
425 return (T);
426 }
427
428 int
f_instance(int arglist)429 f_instance(int arglist)
430 {
431 int arg1,
432 addr;
433
434 arg1 = car(arglist);
435 addr = get_int(arg1);
436 print(addr);
437 return (T);
438 }
439
440 // ----------for Raspberry PI
441 #ifdef __arm__
442 int
f_wiringpi_setup_gpio(int arglist __unused)443 f_wiringpi_setup_gpio(int arglist __unused)
444 {
445 wiringPiSetupGpio();
446 return (T);
447 }
448
449 int
f_wiringpi_spi_setup_ch_speed(int arglist)450 f_wiringpi_spi_setup_ch_speed(int arglist)
451 {
452 int arg1,
453 arg2,
454 x,
455 y;
456
457 if (length(arglist) != 2)
458 error(WRONG_ARGS, "wiringpi-spi-setup-ch-speed", arglist);
459
460 arg1 = car(arglist);
461 arg2 = cadr(arglist);
462 if (!integerp(arg1))
463 error(NOT_INT, "wiringpi-spi-setup-ch-speed", arg1);
464 if (!integerp(arg2))
465 error(NOT_INT, "wiringpi-spi-setup-ch-speed", arg2);
466
467 x = GET_INT(arg1);
468 y = GET_INT(arg2);
469 wiringPiSPISetup(x, y);
470 return (T);
471 }
472
473 int
f_pwm_set_mode(int arglist)474 f_pwm_set_mode(int arglist)
475 {
476 int arg1;
477
478 if (length(arglist) != 1)
479 error(WRONG_ARGS, "pwm-set-mode", arglist);
480
481 arg1 = car(arglist);
482
483 if (arg1 == makesym("pwm-mode-ms"))
484 pwmSetMode(PWM_MODE_MS);
485 else if (arg1 == makesym("pwm-mode-bal"))
486 pwmSetMode(PWM_MODE_BAL);
487 else
488 error(WRONG_ARGS, "pwm-set-mode", arg1);
489
490 return (T);
491 }
492
493 int
f_pwm_set_range(int arglist)494 f_pwm_set_range(int arglist)
495 {
496 int arg1,
497 x;
498
499 if (length(arglist) != 1)
500 error(WRONG_ARGS, "pwm-set-range", arglist);
501
502 arg1 = car(arglist);
503 if (!integerp(arg1))
504 error(NOT_INT, "pwm-set-range", arg1);
505
506 x = GET_INT(arg1);
507 pwmSetRange(x);
508 return (T);
509 }
510
511 int
f_pwm_set_clock(int arglist)512 f_pwm_set_clock(int arglist)
513 {
514 int arg1,
515 x;
516
517 if (length(arglist) != 1)
518 error(WRONG_ARGS, "pwm-set-clock", arglist);
519
520 arg1 = car(arglist);
521 if (!integerp(arg1))
522 error(NOT_INT, "pwm-set-clock", arg1);
523
524 x = GET_INT(arg1);
525 pwmSetClock(x);
526 return (T);
527 }
528
529 int
f_pin_mode(int arglist)530 f_pin_mode(int arglist)
531 {
532 int arg1,
533 arg2,
534 x;
535
536 if (length(arglist) != 2)
537 error(WRONG_ARGS, "pin-mode", arglist);
538
539 arg1 = car(arglist);
540 arg2 = cadr(arglist);
541 if (!integerp(arg1))
542 error(NOT_INT, "pin-,mode", arg1);
543
544 x = GET_INT(arg1);
545 if (arg2 == makesym("intput"))
546 pinMode(x, INPUT);
547 else if (arg2 == makesym("output"))
548 pinMode(x, OUTPUT);
549 else if (arg2 == makesym("pwm-output"))
550 pinMode(x, PWM_OUTPUT);
551 else
552 error(WRONG_ARGS, "pin-mode", arg2);
553
554 return (T);
555 }
556
557 int
f_digital_write(int arglist)558 f_digital_write(int arglist)
559 {
560 int arg1,
561 arg2,
562 x,
563 y;
564
565 if (length(arglist) != 2)
566 error(WRONG_ARGS, "digital-write", arglist);
567
568 arg1 = car(arglist);
569 arg2 = cadr(arglist);
570 if (!integerp(arg1))
571 error(NOT_INT, "digital-write", arg1);
572 if (!integerp(arg2))
573 error(NOT_INT, "digital-write", arg2);
574
575 x = GET_INT(arg1);
576 y = GET_INT(arg2);
577 digitalWrite(x, y);
578 return (T);
579 }
580
581 int
f_digital_write_byte(int arglist)582 f_digital_write_byte(int arglist)
583 {
584 int arg1,
585 x;
586
587 if (length(arglist) != 1)
588 error(WRONG_ARGS, "digital-write-byte", arglist);
589
590 arg1 = car(arglist);
591 if (!integerp(arg1))
592 error(NOT_INT, "digital-write-byte", arg1);
593
594 x = GET_INT(arg1);
595 digitalWriteByte(x);
596 return (T);
597 }
598
599 int
f_pull_up_dn_control(int arglist)600 f_pull_up_dn_control(int arglist)
601 {
602 int arg1,
603 arg2,
604 x,
605 y;
606
607 if (length(arglist) != 2)
608 error(WRONG_ARGS, "pull-up-dn-control", arglist);
609
610 arg1 = car(arglist);
611 arg2 = cadr(arglist);
612 if (!integerp(arg1))
613 error(NOT_INT, "pull-up-dn-control", arg1);
614 if (!integerp(arg2))
615 error(NOT_INT, "pull-up-dn-control", arg2);
616
617 x = GET_INT(arg1);
618 y = GET_INT(arg2);
619 pullUpDnControl(x, y);
620 return (T);
621 }
622
623 int
f_digital_read(int arglist)624 f_digital_read(int arglist)
625 {
626 int arg1,
627 x,
628 res;
629
630 if (length(arglist) != 1)
631 error(WRONG_ARGS, "digital-read", arglist);
632
633 arg1 = car(arglist);
634 if (!integerp(arg1))
635 error(NOT_INT, "digital-read", arg1);
636
637 x = GET_INT(arg1);
638 res = digitalRead(x);
639 return (makeint(res));
640 }
641
642 int
f_delay(int arglist)643 f_delay(int arglist)
644 {
645 int arg1,
646 x;
647
648 if (length(arglist) != 1)
649 error(WRONG_ARGS, "delay", arglist);
650
651 arg1 = car(arglist);
652 if (!integerp(arg1))
653 error(NOT_INT, "delay", arg1);
654
655 x = GET_INT(arg1);
656 delay(x);
657 return (T);
658 }
659
660 int
f_delay_microseconds(int arglist)661 f_delay_microseconds(int arglist)
662 {
663 int arg1,
664 x;
665
666 if (length(arglist) != 1)
667 error(WRONG_ARGS, "delay-microseconds", arglist);
668
669 arg1 = car(arglist);
670 if (!integerp(arg1))
671 error(NOT_INT, "delay-microseconds", arg1);
672
673 x = GET_INT(arg1);
674 delayMicroseconds(x);
675 return (T);
676 }
677 #endif
678
679 int
f_modulesubst(int arglist)680 f_modulesubst(int arglist)
681 {
682 int arg1,
683 arg2,
684 arg3;
685
686 arg1 = car(arglist);
687 arg2 = cadr(arglist);
688 arg3 = caddr(arglist);
689
690 return (modulesubst(arg1, arg2, arg3));
691 }
692
693 int
f_line_argument(int arglist)694 f_line_argument(int arglist)
695 {
696 int arg1,
697 n;
698
699 if (length(arglist) != 1) {
700 error(WRONG_ARGS, "line-argument", arglist);
701 }
702 arg1 = car(arglist);
703 n = GET_INT(arg1);
704 if (n < gArgC) {
705 return makestr(gArgV[n]);
706 } else {
707 return NIL;
708 }
709 }
710
711 int
f_getenv(int arglist)712 f_getenv(int arglist)
713 {
714 int arg1;
715
716 arg1 = car(arglist);
717 if (length(arglist) != 1) {
718 error(WRONG_ARGS, "getenv", arglist);
719 }
720 char *val = getenv(GET_NAME(arg1));
721 if (val == NULL) {
722 return NIL;
723 } else {
724 return makestr(val);
725 }
726 }
727
728 /*
729 * f_superp_for_compiler (superp-for-compiler) is used in compiler.lsp.
730 * for generate (call-next-method)
731 * compare entry-parameter and next-method-parameter.
732 * when entry-parameter is super-call than next-method-patarmeter, compiler must not generate next-method
733 * see verify/object.lsp test-case foo-30
734 */
735
736 int
f_superp_for_compiler(int arglist)737 f_superp_for_compiler(int arglist)
738 {
739 int arg1,
740 arg2;
741
742 arg1 = car(arglist);
743 arg2 = cadr(arglist);
744
745 if (length(arglist) != 2) {
746 error(WRONG_ARGS, "eisl-superp-for-compiler", arglist);
747 }
748
749 if (superp(arg1, arg2))
750 return (T);
751 else
752 return (NIL);
753 }
754
755 int
superp(int entry,int next)756 superp(int entry, int next)
757 {
758
759 if (nullp(entry) && nullp(next))
760 return (1);
761 else if (symbolp(car(entry)))
762 return (superp(cdr(entry), cdr(next)));
763 else if (subclassp(GET_AUX(cadar(next)), GET_AUX(cadar(entry)))) // subclass
764 return (superp(cdr(entry), cdr(next)));
765 else if (eqp(GET_AUX(cadar(next)), GET_AUX(cadar(entry)))) // same
766 // class
767 return (superp(cdr(entry), cdr(next)));
768 else
769 return (0);
770 }
771