1 /*
2 * Easy-ISLisp (ISLisp) written by kenichi sasagawa 2016/4~
3 */
4
5 #include <stdio.h>
6 #include <string.h>
7 #include <ctype.h>
8 #include <stdlib.h>
9 #include <math.h>
10 #include <limits.h>
11 #include <signal.h>
12 #include <unistd.h>
13 #include <getopt.h>
14 #include <ncurses.h>
15 #include <term.h>
16 #include "eisl.h"
17 #include "mem.h"
18 #include "fmt.h"
19 #include "except.h"
20 #include "str.h"
21 #include "long.h"
22 #include "eiffel.h"
23
24 // ------pointer----
25 int ep; // environment pointer
26 int dp; // dynamic pointer
27 int hp; // heap pointer for mark and sweep
28 int sp; // stack pointer
29 int fc; // free counter
30 int ap; // arglist pointer
31 int lp; // shelter pointer
32 int wp; // working pointer for copy GC
33
34
35 // ------class-----
36 int cobject;
37 int cbasic_array;
38 int cbasic_array_star;
39 int cgeneral_array_star;
40 int cbasic_vector;
41 int cgeneral_vector;
42 int cstring;
43 int cbuilt_in_class;
44 int ccharacter;
45 int cfunction;
46 int cgeneric_function;
47 int cstandard_generic_function;
48 int clist;
49 int ccons;
50 int cnull;
51 int csymbol;
52 int cnumber;
53 int cfloat;
54 int cinteger;
55 int cserious_condition;
56 int cerror;
57 int carithmetic_error;
58 int cdivision_by_zero;
59 int cfloating_point_overflow;
60 int cfloating_point_underflow;
61 int ccontrol_error;
62 int cparse_error;
63 int cprogram_error;
64 int cdomain_error;
65 int cclass_error;
66 int cundefined_entity;
67 int cunbound_variable;
68 int cundefined_function;
69 int csimple_error;
70 int cstream_error;
71 int cend_of_stream;
72 int cstorage_exhausted;
73 int cstandard_class;
74 int cstandard_object;
75 int cstream;
76 int cinvalid;
77 int cfixnum;
78 int clongnum;
79 int cbignum;
80
81
82 // stream
83 int standard_input;
84 int standard_output;
85 int standard_error;
86 int input_stream;
87 int output_stream;
88 int error_stream;
89 char stream_str[STRSIZE];
90 int charcnt; // for format-tab. store number of chars
91 // up to now.
92
93
94 // read scaner
95 token stok = { '\0', GO, OTHER, {'\0'} };
96
97 int line;
98 int column;
99 int buffer[COL_SIZE + 1][NUM_HISTORY];
100 int buffer1[COL_SIZE + 1];
101
102
103 // heap and stack
104 cell heap[CELLSIZE];
105 int stack[STACKSIZE];
106 int argstk[STACKSIZE];
107 int cell_hash_table[HASHTBSIZE];
108 int shelter[STACKSIZE];
109 int dynamic[DYNSIZE][2];
110
111 // object oriented
112 int generic_func; // generic function in eval.
113 int generic_vars; // args list of generic function in eval.
114 int next_method; // head address of finded method.
115 int generic_list = NIL; // symbol list of generic
116 // function.
117
118 // flag
119 int gArgC;
120 char **gArgV;
121 bool gbc_flag = false; // false=GC not display ,true= do
122 // display.
123 int genint = 1; // integer of gensym.
124 bool simp_flag = true; // true=simplify, false=Not for
125 // bignum
126 bool ignore_flag = false; // false=normal,true=ignore error
127 bool open_flag = false; // false=normal,true=now loading
128 bool top_flag = true; // true=top-level,false=not-top-level
129 bool redef_flag = false; // true=redefine-class,false=not-redefine
130 bool start_flag = true; // true=line-start,false=not-line-start
131 bool back_flag = true; // for backtrace,
132 // true=on,false=off
133 bool ignore_topchk = false; // for FAST
134 // compilertrue=ignore,false=normal
135 bool repl_flag = true; // for REPL read_line 1=on, 0=off
136 volatile sig_atomic_t exit_flag = 0; // true= ctrl+C
137 bool greeting_flag = true; // for (quit)
138 bool script_flag = false; // for -s option
139 bool handling_resource_err = false; // stop infinite recursion
140 bool looking_for_shebang = false; // skip over #!
141 bool multiple_call_next_method; // method body has
142 // multiple
143 // (call-next-method)
144
145 // switch
146 int gc_sw = 0; // 0= mark-and-sweep-GC 1= copy-GC
147 int area_sw = 1; // 1= lower area 2=higher area
148
149 // longjmp control and etc
150 Except_T Restart_Repl = { "Restart REPL" }, Exit_Interp =
151 { "Exit interpreter" };
152 jmp_buf block_buf[NESTED_BLOCKS_MAX];
153 int block_tag_check[NESTED_BLOCKS_MAX];
154 int block_env[NESTED_BLOCKS_MAX][2];
155 jmp_buf catch_buf[10][50];
156 int catch_env[10][50];
157 Except_T Ignored_Error = { "Ignored error" }; // for
158 // ignore-errors
159
160 int block_tag[CTRLSTK]; // array of tag
161 int catch_tag[CTRLSTK];
162 int unwind_buf[CTRLSTK];
163 int catch_symbols = NIL; // to clear tag data
164 int block_pt; // index of block. following are similer
165 int catch_pt = 0; // catch counter
166 int unwind_pt; // lambda address for unwind-protect
167 int block_arg; // receive argument of block
168 int catch_arg; // receive argument of catch
169 int tagbody_tag = NIL; // tag address fo tagbody
170 int error_handler; // for store first argument of
171 // with-handler
172 int trace_list = NIL; // function list of trace
173 int backtrace[BACKSIZE];
174
175 // -----debugger-----
176 int examin_sym;
177 int stepper_flag = 0;
178
179
180 int ed_lparen_col;
181 int ed_rparen_col;
182 const char *ed_candidate[COMPLETION_CANDIDATES_MAX];
183 int ed_candidate_pt;
184 const short ed_syntax_color = COLOR_RED;
185 const short ed_builtin_color = COLOR_CYAN;
186 const short ed_extended_color = COLOR_MAGENTA;
187 const short ed_string_color = COLOR_YELLOW;
188 const short ed_comment_color = COLOR_BLUE;
189 int ed_incomment = -1; // #|...|# comment
190
191 // Defaults, should be filled in later
192 char ed_key_up = 'A';
193 char ed_key_down = 'B';
194 char ed_key_right = 'C';
195 char ed_key_left = 'D';
196
197 static void
usage(void)198 usage(void)
199 {
200 puts("List of options:\n"
201 "-c -- EISL starts after reading compiler.lsp.\n"
202 "-f -- EISL starts after reading formatter.lsp.\n"
203 "-h -- display help.\n"
204 "-l filename -- EISL starts after reading the file.\n"
205 "-r -- EISL does not use editable REPL.\n"
206 "-s filename -- EISL runs the file with script mode.\n"
207 "-v -- display version number.");
208 }
209
210 static inline void
maybe_greet(void)211 maybe_greet(void)
212 {
213 if (greeting_flag)
214 Fmt_print("Easy-ISLisp Ver%1.2f\n", VERSION);
215 }
216
217 int
main(int argc,char * argv[])218 main(int argc, char *argv[])
219 {
220 int errret;
221
222 Fmt_register('D', cvt_D);
223 if (setupterm((char *) 0, 1, &errret) == ERR ||
224 key_up == NULL || key_down == NULL ||
225 key_right == NULL || key_left == NULL) {
226 repl_flag = false;
227 } else {
228 ed_key_down = key_down[2];
229 ed_key_left = key_left[2];
230 ed_key_right = key_right[2];
231 ed_key_up = key_up[2];
232 }
233
234 initcell();
235 initclass();
236 initstream();
237 initsubr();
238 initexsubr();
239 initsyntax();
240 initgeneric();
241 signal(SIGINT, signal_handler_c);
242 signal(SIGTSTP, SIG_IGN);
243 signal(SIGSTOP, SIG_IGN);
244
245 input_stream = standard_input;
246 output_stream = standard_output;
247 error_stream = standard_error;
248
249 int ch;
250 char *script_arg;
251
252 if (access("startup.lsp", R_OK) == 0) {
253 f_load(list1(makestr("startup.lsp")));
254 }
255 while ((ch = getopt(argc, argv, "l:cfs:rhv")) != -1) {
256 char *str;
257
258 switch (ch) {
259 case 'l':
260 f_load(list1(makestr(optarg)));
261 break;
262 case 'c':
263 str = library_file("compiler.lsp");
264 f_load(list1(makestr(str)));
265 FREE(str);
266 break;
267 case 'f':
268 str = library_file("formatter.lsp");
269 f_load(list1(makestr(str)));
270 FREE(str);
271 break;
272 case 's':
273 if (access(optarg, R_OK) == -1) {
274 puts("File doesn't exist.");
275 exit(EXIT_FAILURE);
276 }
277 repl_flag = false;
278 script_flag = true;
279 looking_for_shebang = true;
280 script_arg = optarg;
281 break;
282 case 'r':
283 repl_flag = false;
284 break;
285 case 'v':
286 Fmt_print("Easy-ISLisp Ver%1.2f\n", VERSION);
287 exit(EXIT_SUCCESS);
288 case 'h':
289 usage();
290 exit(EXIT_SUCCESS);
291 default:
292 usage();
293 exit(EXIT_FAILURE);
294 }
295 }
296 gArgC = argc - optind;
297 gArgV = argv + optind;
298 if (script_flag) {
299 f_load(list1(makestr(script_arg)));
300 exit(EXIT_SUCCESS);
301 }
302 volatile bool quit = false;
303 do {
304 maybe_greet();
305 TRY while (1) {
306 initpt();
307 fputs("> ", stdout);
308 print(eval(sread()));
309 putchar('\n');
310 if (redef_flag)
311 redef_generic();
312 }
313 EXCEPT(Restart_Repl);
314 EXCEPT(Exit_Interp)
315 quit = true;
316 END_TRY;
317 } while (!quit);
318 }
319
320 char *
library_file(const char * basename)321 library_file(const char *basename)
322 {
323 char *prefix;
324
325 if ((prefix = getenv("EASY_ISLISP")) != NULL) {
326 return Str_catv(prefix, 1, 0, "/library/", 1, 0, basename, 1, 0,
327 NULL);
328 }
329 return Str_catv(getenv("HOME"), 1, 0, "/eisl/library/", 1, 0, basename,
330 1, 0, NULL);
331 }
332
333 void
initpt(void)334 initpt(void)
335 {
336 int ls;
337
338 ep = 0;
339 sp = 0;
340 ap = 0;
341 lp = 0;
342 ls = catch_symbols;
343 while (!nullp(ls)) {
344 SET_PROP(car(ls), 0);
345 SET_OPT(car(ls), 0);
346 ls = cdr(ls);
347 }
348 block_pt = 0;
349 catch_pt = 0;
350 unwind_pt = 0;
351 error_handler = NIL;
352 top_flag = true;
353 start_flag = true;
354 charcnt = 0;
355 generic_func = NIL;
356 generic_vars = NIL;
357 // clear nest level of tracing function.
358 ls = trace_list;
359 while (!nullp(ls)) {
360 SET_TR(GET_CAR(car(ls)), 0);
361 ls = cdr(ls);
362 }
363 }
364
365
366 void
signal_handler_c(int signo __unused)367 signal_handler_c(int signo __unused)
368 {
369 exit_flag = 1;
370 }
371
372
373
374
375 // -------read()--------
376 int
readc(void)377 readc(void)
378 {
379 int c;
380 if (input_stream == standard_input && repl_flag)
381 c = read_line(1);
382 else if (GET_OPT(input_stream) != EISL_INSTR) {
383 c = getc(GET_PORT(input_stream));
384 // ctrl+D
385 // if not script-mode quit system
386 if (!script_flag && input_stream == standard_input && c == EOF) {
387 greeting_flag = false;
388 putchar('\n');
389 RAISE(Exit_Interp);
390 } else // if script-mode return(EOF)
391 return (c);
392
393 } else {
394 c = GET_NAME(input_stream)[GET_CDR(input_stream)];
395 SET_CDR(input_stream, GET_CDR(input_stream) + 1);
396 if (c == '\\') {
397 c = GET_NAME(input_stream)[GET_CDR(input_stream)];
398 SET_CDR(input_stream, GET_CDR(input_stream) + 1);
399 } else if (c == NUL) {
400 c = EOF;
401 SET_CDR(input_stream, GET_CDR(input_stream) - 1);
402 }
403 }
404
405 if (c == EOL) {
406 line++;
407 column = 0;
408 } else
409 column++;
410
411 return (c);
412 }
413
414 void
unreadc(char c)415 unreadc(char c)
416 {
417 if (c == EOL)
418 line--;
419 else
420 column--;
421 if (input_stream == standard_input && repl_flag)
422 (void) read_line(-1);
423 else if (GET_OPT(input_stream) != EISL_INSTR)
424 ungetc(c, GET_PORT(input_stream));
425 else if (c != EOF)
426 SET_CDR(input_stream, GET_CDR(input_stream) - 1);
427 }
428
429
430
431 void
gettoken(void)432 gettoken(void)
433 {
434 int c;
435 int pos;
436 int res;
437
438 if (stok.flag == BACK) {
439 stok.flag = GO;
440 return;
441 }
442
443 if (stok.ch == ')') {
444 stok.type = RPAREN;
445 stok.ch = NUL;
446 return;
447 }
448
449 if (stok.ch == '(') {
450 stok.type = LPAREN;
451 stok.ch = NUL;
452 return;
453 }
454
455 c = readc();
456
457 skip:
458 while (c == SPACE || c == EOL || c == TAB || c == RET)
459 c = readc();
460
461 // skip comment line
462 // if find EOF at end of line, return FILEEND.
463 if (c == ';') {
464 while (!(c == EOL)) {
465 c = readc();
466 if (c == EOF) {
467 stok.type = FILEEND;
468 return;
469 }
470 }
471 goto skip;
472 }
473 // if end of file,return FILEEND.
474 if (c == EOF) {
475 stok.type = FILEEND;
476 return;
477 }
478
479 switch (c) {
480 case '(':
481 stok.type = LPAREN;
482 break;
483 case ')':
484 stok.type = RPAREN;
485 break;
486 case '\'':
487 stok.type = QUOTE;
488 break;
489 case '.':
490 stok.type = DOT;
491 break;
492 case '`':
493 stok.type = BACKQUOTE;
494 break;
495 case ',':
496 stok.type = COMMA;
497 break;
498 case '@':
499 stok.type = ATMARK;
500 break;
501 case '"':{
502 c = readc();
503 pos = 0;
504 while (c != '"') {
505 stok.buf[pos++] = c;
506 if (c == '\\') {
507 c = readc();
508 stok.buf[pos++] = c;
509 }
510 if (c == EOF) {
511 error(SYSTEM_ERR, "not exist right hand double quote",
512 NIL);
513 }
514 c = readc();
515 }
516 stok.buf[pos] = NUL;
517 stok.type = STRING;
518 break;
519 }
520 case '#':{
521 c = readc();
522 if (c == '\'') {
523 stok.type = FUNCTION;
524 break;
525 } else if (c == '(') {
526 stok.type = VECTOR;
527 break;
528 } else if (c == '\\') {
529 c = readc();
530 pos = 0;
531 stok.buf[pos++] = c;
532 if (c == ' ')
533 goto chskip;
534
535 while (((c = readc()) != EOL) && (c != EOF)
536 && (pos < BUFSIZE - 1) && (c != SPACE) && (c != '(')
537 && (c != ')')) {
538 stok.buf[pos++] = c;
539 }
540
541 chskip:
542 stok.buf[pos] = NUL;
543 stok.type = CHARACTER;
544 if (c == EOF)
545 stok.ch = ' ';
546 else
547 stok.ch = c;
548 break;
549 } else if (isdigit(c)) {
550 pos = 0;
551 while (isdigit(c)) {
552 stok.buf[pos] = c;
553 pos++;
554 c = readc();
555 }
556 stok.buf[pos] = NUL;
557 if (c == 'a' || c == 'A') {
558 stok.type = ARRAY;
559 break;
560 } else {
561 stok.type = OTHER;
562 return;
563 }
564 }
565 if (c == '|') {
566 reskip:
567 c = readc();
568 while (c != '|') {
569 c = readc();
570 }
571 c = readc();
572 if (c == '#') {
573 c = readc();
574 goto skip;
575 } else
576 goto reskip;
577 } else
578 unreadc(c);
579 c = '#';
580 }
581 /*FALLTHROUGH*/ default:{
582 pos = 0;
583 stok.buf[pos++] = c;
584 while (((c = readc()) != EOL) && (c != EOF)
585 && (pos < BUFSIZE - 1) && (c != SPACE) && (c != '(')
586 && (c != ')') && (c != '`') && (c != ',') && (c != '@'))
587 stok.buf[pos++] = c;
588
589 stok.buf[pos] = NUL;
590 stok.ch = c;
591
592 if (flttoken(stok.buf)) {
593 stok.type = FLOAT_N;
594 break;
595 }
596 // first step,check bignum. inttoken() ignores number of
597 // digits.
598 if (bignumtoken(stok.buf)) {
599 stok.type = BIGNUM;
600 break;
601 }
602 if (inttoken(stok.buf)) {
603 stok.type = INTEGER;
604 break;
605 }
606 if (inttoken_nsgn(stok.buf)) {
607 stok.type = INTEGER;
608 break;
609 }
610 if (bintoken(stok.buf)) {
611 stok.type = BINARY;
612 break;
613 }
614 if (octtoken(stok.buf)) {
615 stok.type = OCTAL;
616 break;
617 }
618 if (dectoken(stok.buf)) {
619 stok.type = DECNUM;
620 break;
621 }
622 if (hextoken(stok.buf)) {
623 stok.type = HEXNUM;
624 break;
625 }
626 if ((res = expttoken(stok.buf))) {
627 if (res == 2)
628 stok.type = EXPTOVERF;
629 else if (res == 3)
630 stok.type = EXPTUNDERF;
631 else
632 stok.type = EXPTNUM;
633 break;
634 }
635 if (symboltoken(stok.buf)) {
636 stok.type = SYMBOL;
637 break;
638 }
639 stok.type = OTHER;
640 }
641 }
642 }
643
644 septoken
separater(char buf[],char sep)645 separater(char buf[], char sep)
646 {
647 int i,
648 j;
649 char c;
650 septoken res;
651
652 res.sepch = NUL;
653 res.after[0] = NUL;
654
655 res.before[0] = buf[0];
656 i = 1;
657 j = 1;
658 while ((c = buf[i]) != NUL)
659 if (c == sep) {
660 res.before[j] = NUL;
661 res.sepch = sep;
662 i++;
663 j = 0;
664 while ((c = buf[i]) != NUL) {
665 res.after[j] = c;
666 i++;
667 j++;
668 }
669 res.after[j] = NUL;
670 } else {
671 res.before[j] = c;
672 i++;
673 j++;
674 }
675 return (res);
676 }
677
678 void
insertstr(char ch,char buf[])679 insertstr(char ch, char buf[])
680 {
681 int i;
682
683 i = laststr(buf) + 1;
684 while (i >= 0) {
685 buf[i + 1] = buf[i];
686 i--;
687 }
688 buf[0] = ch;
689 }
690
691 int
laststr(char buf[])692 laststr(char buf[])
693 {
694 int i;
695
696 i = 0;
697 while (buf[i] != NUL)
698 i++;
699 return (i - 1);
700 }
701
702
703 // remove #\ from char, for example #\a -> a.
704 void
dropchar(char buf[])705 dropchar(char buf[])
706 {
707 int i,
708 j;
709
710 j = laststr(buf);
711 for (i = 2; i <= j; i++)
712 buf[i - 2] = buf[i];
713 buf[i - 2] = NUL;
714 }
715
716
717 // integer of sign. ignore number of digits.
718 int
inttoken(char buf[])719 inttoken(char buf[])
720 {
721 int i;
722 char c;
723
724 if (buf[0] == NUL) // null string
725 return (0);
726
727 if (((buf[0] == '+') || (buf[0] == '-'))) {
728 if (buf[1] == NUL)
729 return (0); // case {+,-} => symbol
730 i = 1;
731 while ((c = buf[i]) != NUL)
732 if (isdigit(c))
733 i++; // case {+123..., -123...}
734 else
735 return (0);
736 } else {
737 i = 0; // {1234...}
738 while ((c = buf[i]) != NUL)
739 if (isdigit(c))
740 i++;
741 else
742 return (0);
743 }
744 return (1);
745 }
746
747 // integer without sign
748 int
inttoken_nsgn(char buf[])749 inttoken_nsgn(char buf[])
750 {
751 int i;
752 char c;
753
754 i = 0;
755 while ((c = buf[i]) != NUL) {
756 if (isdigit(c))
757 i++;
758 else
759 return (0);
760 }
761 return (1);
762 }
763
764 int
flttoken(char buf[])765 flttoken(char buf[])
766 {
767 septoken tok;
768
769 if (buf[0] == '.') {
770 char bufcp[SYMSIZE];
771
772 if (buf[1] == '0')
773 return (0);
774 strncpy(bufcp, buf, SYMSIZE - 1);
775 bufcp[SYMSIZE - 1] = '\0';
776 insertstr('0', bufcp);
777 if (flttoken(bufcp))
778 return (1);
779 }
780
781
782 tok = separater(buf, '.');
783
784 if (tok.sepch == NUL)
785 return (0);
786
787 if (tok.after[0] == NUL) // "".""
788 return (0);
789 else if (inttoken(tok.before) && inttoken_nsgn(tok.after))
790 return (1);
791 else
792 return (0);
793 }
794
795 int
bignumtoken(char buf[])796 bignumtoken(char buf[])
797 {
798 int i;
799 char c;
800
801 if (((buf[0] == '+') || (buf[0] == '-'))) {
802 if (buf[1] == NUL)
803 return (0); // case {+,-} => symbol
804 i = 1;
805 while ((c = buf[i]) != NUL)
806 if (isdigit(c))
807 i++; // case {+123..., -123...}
808 else
809 return (0);
810 if (strlen(buf) <= 10)
811 return (0); // case not bignum
812 } else {
813 i = 0; // {1234...}
814 while ((c = buf[i]) != NUL)
815 if (isdigit(c))
816 i++;
817 else
818 return (0);
819 if (strlen(buf) <= 9)
820 return (0); // case not bignum
821 }
822 return (1); // bignum
823 }
824
825
826 int
symboltoken(char buf[])827 symboltoken(char buf[])
828 {
829 int i;
830 char c;
831
832 i = 0;
833 while ((c = buf[i]) != NUL)
834 if ((isalpha(c)) || (isdigit(c)) || (issymch(c)))
835 i++;
836 else
837 return (0);
838
839 // fold to upper letter.
840 i = 0;
841 while ((c = buf[i]) != NUL) {
842 buf[i] = toupper(c);
843 i++;
844 }
845 return (1);
846 }
847
848 int
bintoken(char buf[])849 bintoken(char buf[])
850 {
851 int i;
852 char c;
853
854 if (!(buf[0] == '#' && (buf[1] == 'b' || buf[1] == 'B')))
855 return (0);
856
857 if (buf[2] == '+' || buf[2] == '-')
858 i = 3;
859 else
860 i = 2;
861
862 while ((c = buf[i]) != NUL)
863 if (c == '0' || c == '1')
864 i++;
865 else
866 return (0);
867
868 if (i == 3 && (buf[2] == '+' || buf[2] == '-'))
869 return (0);
870 else if (i != 2) {
871 dropchar(buf);
872 return (1);
873 } else
874 return (0);
875 }
876
877 int
octtoken(char buf[])878 octtoken(char buf[])
879 {
880 int i;
881 char c;
882
883 if (!(buf[0] == '#' && (buf[1] == 'o' || buf[1] == 'O')))
884 return (0);
885 if (buf[2] == '+' || buf[2] == '-')
886 i = 3;
887 else
888 i = 2;
889
890 while ((c = buf[i]) != NUL)
891 if (c == '0' || c == '1' || c == '2' || c == '3' || c == '4' ||
892 c == '5' || c == '6' || c == '7')
893 i++;
894 else
895 return (0);
896
897 if (i == 3 && (buf[2] == '+' || buf[2] == '-'))
898 return (0);
899 else if (i != 2) {
900 dropchar(buf);
901 return (1);
902 } else
903 return (0);
904 }
905
906 int
dectoken(char buf[])907 dectoken(char buf[])
908 {
909 int i;
910 char c;
911
912 if (!(buf[0] == '#' && (buf[1] == 'd' || buf[1] == 'D')))
913 return (0);
914 if (buf[2] == '+' || buf[2] == '-')
915 i = 3;
916 else
917 i = 2;
918
919 while ((c = buf[i]) != NUL)
920 if (isdigit(c))
921 i++;
922 else
923 return (0);
924
925 if (i != 2) {
926 dropchar(buf);
927 return (1);
928 } else
929 return (0);
930 }
931
932 int
hextoken(char buf[])933 hextoken(char buf[])
934 {
935 int i;
936 char c;
937
938 if (!(buf[0] == '#' && (buf[1] == 'x' || buf[1] == 'X')))
939 return (0);
940 if (buf[2] == '+' || buf[2] == '-')
941 i = 3;
942 else
943 i = 2;
944
945 while ((c = buf[i]) != NUL)
946 if (isxdigit(c))
947 i++;
948 else
949 return (0);
950
951 if (i == 3 && (buf[2] == '+' || buf[2] == '-'))
952 return (0);
953 else if (i != 2) {
954 dropchar(buf);
955 return (1);
956 } else
957 return (0);
958 }
959
960
961 int
expttoken(char buf[])962 expttoken(char buf[])
963 {
964 septoken tok;
965 char buf1[BUFSIZE];
966
967 if (buf[0] == '.') // e.g. ".2E3"
968 return (0);
969
970 strncpy(buf1, buf, BUFSIZE - 1);
971 buf1[BUFSIZE - 1] = '\0';
972 tok = separater(buf, 'e');
973 if (tok.sepch != NUL &&
974 (inttoken(tok.before) || flttoken(tok.before)) &&
975 inttoken(tok.after)) {
976 if (atoi(tok.after) > 999)
977 return (2); // overflow
978 else if (atoi(tok.after) < -999)
979 return (3); // underflow
980 else
981 return (1); // regular
982 }
983
984 strncpy(buf, buf1, BUFSIZE - 1);
985 buf[BUFSIZE - 1] = '\0';
986 tok = separater(buf, 'E');
987 if (tok.sepch == NUL)
988 return (0);
989 if ((inttoken(tok.before) || flttoken(tok.before)) &&
990 inttoken(tok.after)) {
991 if (atoi(tok.after) > 999)
992 return (2); // overflow
993 else if (atoi(tok.after) < -999)
994 return (3); // underflow
995 else
996 return (1); // regular
997 } else
998 return (0);
999 }
1000
1001
1002 int
issymch(char c)1003 issymch(char c)
1004 {
1005 switch (c) {
1006 case '!':
1007 case '?':
1008 case '+':
1009 case '-':
1010 case '*':
1011 case '/':
1012 case '=':
1013 case '<':
1014 case '>':
1015 case '_':
1016 case '.':
1017 case ':':
1018 case '#':
1019 case '$':
1020 case '@':
1021 case '%':
1022 case '&':
1023 case '~':
1024 case '^':
1025 case '|':
1026 case '\\':
1027 case '{':
1028 case '}':
1029 case '[':
1030 case ']':
1031 return (1);
1032 default:
1033 return (0);
1034 }
1035 }
1036
1037
1038 int
sread(void)1039 sread(void)
1040 {
1041 int n;
1042 char *e;
1043
1044 gettoken();
1045 switch (stok.type) {
1046 case FILEEND:
1047 return (FEND);
1048 case INTEGER:
1049 return (makeint(atoi(stok.buf)));
1050 case FLOAT_N:
1051 return (makeflt(atof(stok.buf)));
1052 case BIGNUM:
1053 return (makebigx(stok.buf));
1054 case DECNUM:
1055 return (makeint((int) strtol(stok.buf, &e, 10)));
1056 case BINARY:
1057 return (readbin(stok.buf));
1058 case OCTAL:
1059 return (readoct(stok.buf));
1060 case HEXNUM:
1061 return (readhex(stok.buf));
1062 case EXPTNUM:
1063 return (makeflt(atof(stok.buf)));
1064 case EXPTOVERF:
1065 error(FLT_OVERF, "read", NIL);
1066 break;
1067 case EXPTUNDERF:
1068 error(FLT_UNDERF, "read", NIL);
1069 break;
1070 case VECTOR:
1071 return (vector(readlist()));
1072 case ARRAY:
1073 n = atoi(stok.buf);
1074 return (array(n, sread()));
1075 case STRING:
1076 return (makestr(stok.buf));
1077 case CHARACTER:
1078 return (makechar(stok.buf));
1079 case SYMBOL:
1080 return (makesym(stok.buf));
1081 case QUOTE:
1082 return (cons(makesym("QUOTE"), cons(sread(), NIL)));
1083 case BACKQUOTE:
1084 return (cons(makesym("QUASI-QUOTE"), cons(sread(), NIL)));
1085 case COMMA:{
1086 gettoken();
1087 if (stok.type == ATMARK)
1088 return (cons
1089 (makesym("UNQUOTE-SPLICING"), cons(sread(), NIL)));
1090 else {
1091 stok.flag = BACK;
1092 return (cons(makesym("UNQUOTE"), cons(sread(), NIL)));
1093 }
1094 }
1095 case FUNCTION:
1096 return (cons(makesym("FUNCTION"), cons(sread(), NIL)));
1097 case LPAREN:
1098 return (readlist());
1099 case RPAREN:
1100 error(ILLEGAL_RPAREN, "read", NIL);
1101 default:
1102 break;
1103 }
1104 Fmt_fprint(GET_PORT(error_stream), "%d%s", (int) stok.type, stok.buf);
1105 error(ILLEGAL_INPUT, "read", NIL);
1106 return (0);
1107 }
1108
1109 int
readlist(void)1110 readlist(void)
1111 {
1112 int rl_car,
1113 rl_cdr;
1114
1115 gettoken();
1116 if (stok.type == RPAREN)
1117 return (NIL);
1118 else if (stok.type == DOT) {
1119 rl_cdr = sread();
1120 if (rl_cdr == FEND)
1121 error(ILLEGAL_RPAREN, "read", makesym("file end"));
1122 gettoken();
1123 return (rl_cdr);
1124 } else {
1125 stok.flag = BACK;
1126 rl_car = sread();
1127 if (rl_car == FEND)
1128 error(ILLEGAL_RPAREN, "read", makesym("file end"));
1129 rl_cdr = readlist();
1130 return (cons(rl_car, rl_cdr));
1131 }
1132 }
1133
1134 int
readbin(char * buf)1135 readbin(char *buf)
1136 {
1137 char str[BUFSIZE],
1138 *e;
1139 int pos,
1140 n,
1141 res,
1142 inc;
1143
1144 n = strlen(buf);
1145 if (n <= 31)
1146 return (makeint((int) strtol(buf, &e, 2)));
1147
1148 pos = 0;
1149 res = makeint(0);
1150 inc = makeint(2);
1151
1152 while (pos < n) {
1153 int part;
1154
1155 str[0] = buf[pos];
1156 str[1] = NUL;
1157 pos++;
1158 part = makeint((int) strtol(str, &e, 2));
1159 res = plus(mult(res, inc), part);
1160 }
1161 return (res);
1162 }
1163
1164 int
readoct(char * buf)1165 readoct(char *buf)
1166 {
1167 char str[BUFSIZE],
1168 *e;
1169 int pos,
1170 n,
1171 res,
1172 inc;
1173
1174 n = strlen(buf);
1175 if (n <= 10)
1176 return (makeint((int) strtol(buf, &e, 8)));
1177
1178 pos = 0;
1179 res = makeint(0);
1180 inc = makeint(8);
1181
1182 while (pos < n) {
1183 int part;
1184
1185 str[0] = buf[pos];
1186 str[1] = NUL;
1187 pos++;
1188 part = makeint((int) strtol(str, &e, 8));
1189 res = plus(mult(res, inc), part);
1190 }
1191 return (res);
1192 }
1193
1194
1195 int
readhex(char * buf)1196 readhex(char *buf)
1197 {
1198 char str[BUFSIZE],
1199 *e;
1200 int pos,
1201 n,
1202 res,
1203 inc;
1204
1205 n = strlen(buf);
1206 if (n <= 7)
1207 return (makeint((int) strtol(buf, &e, 16)));
1208
1209 pos = 0;
1210 res = makeint(0);
1211 inc = makeint(16);
1212
1213 while (pos < n) {
1214 int part;
1215
1216 str[0] = buf[pos];
1217 str[1] = NUL;
1218 pos++;
1219 part = makeint((int) strtol(str, &e, 16));
1220 res = plus(mult(res, inc), part);
1221 }
1222 return (res);
1223 }
1224
1225 // -----print------------------
1226 void
print(int addr)1227 print(int addr)
1228 {
1229 switch (GET_TAG(addr)) {
1230 case INTN:
1231 printint(addr);
1232 break;
1233 case FLTN:
1234 printflt(GET_FLT(addr));
1235 break;
1236 case LONGN:
1237 printlong(addr);
1238 break;
1239 case BIGX:
1240 print_bigx(addr);
1241 break;
1242 case VEC:
1243 printvec(addr);
1244 break;
1245 case ARR:
1246 printarray(addr);
1247 break;
1248 case STR:
1249 printstr(addr);
1250 break;
1251 case CHR:
1252 printchar(addr);
1253 break;
1254 case SYM:
1255 printsym(addr);
1256 break;
1257 case SUBR:
1258 printobj("<subr>");
1259 break;
1260 case FSUBR:
1261 printobj("<fsubr>");
1262 break;
1263 case FUNC:
1264 printobj("<function>");
1265 break;
1266 case MACRO:
1267 printobj("<macro>");
1268 break;
1269 case CLASS:
1270 printclass(addr);
1271 break;
1272 case STREAM:
1273 printstream(addr);
1274 break;
1275 case GENERIC:
1276 printobj("<generic>");
1277 break;
1278 case METHOD:
1279 printobj("<method>");
1280 break;
1281 case INSTANCE:
1282 printobj("<instance>");
1283 break;
1284 case LIS:
1285 output_char(output_stream, '(');
1286 printlist(addr);
1287 break;
1288 case DUMMY:
1289 printobj("<undef*>");
1290 break;
1291 default:
1292 printobj("<undef>");
1293 break;
1294 }
1295 }
1296
1297 void
printint(int addr)1298 printint(int addr)
1299 {
1300 if (GET_OPT(output_stream) != EISL_OUTSTR)
1301 Fmt_fprint(GET_PORT(output_stream), "%d", GET_INT(addr));
1302 else {
1303 char str[SHORT_STRSIZE];
1304 Fmt_sfmt(str, SHORT_STRSIZE, "%d", GET_INT(addr));
1305 append_str(output_stream, str);
1306 }
1307 }
1308
1309 void
printflt(double x)1310 printflt(double x)
1311 {
1312 if (GET_OPT(output_stream) != EISL_OUTSTR) {
1313 fprintf(GET_PORT(output_stream), "%g", x);
1314 if ((x - (int) x) == 0.0)
1315 fprintf(GET_PORT(output_stream), ".0");
1316 } else {
1317 char str[SHORT_STRSIZE];
1318 snprintf(str, SHORT_STRSIZE, "%g", x);
1319 append_str(output_stream, str);
1320 if ((x - (int) x) == 0.0)
1321 append_str(output_stream, ".0");
1322 }
1323 }
1324
1325
1326 void
printlong(int addr)1327 printlong(int addr)
1328 {
1329 if (GET_OPT(output_stream) != EISL_OUTSTR) {
1330 Fmt_fprint(GET_PORT(output_stream), "%D", GET_LONG(addr));
1331 } else {
1332 char str[SHORT_STRSIZE];
1333 Fmt_sfmt(str, SHORT_STRSIZE, "%D", GET_LONG(addr));
1334 append_str(output_stream, str);
1335 }
1336 }
1337
1338
1339 void
printlist(int addr)1340 printlist(int addr)
1341 {
1342 if (IS_NIL(addr)) {
1343 output_char(output_stream, ')');
1344 } else if ((!(listp(cdr(addr)))) && (!(nullp(cdr(addr))))) {
1345 print(car(addr));
1346 output_str(output_stream, " . ");
1347 print(cdr(addr));
1348 output_char(output_stream, ')');
1349 } else {
1350 print(GET_CAR(addr));
1351 if (!(IS_NIL(GET_CDR(addr)))) {
1352 output_char(output_stream, ' ');
1353 }
1354 printlist(GET_CDR(addr));
1355 }
1356 }
1357
1358 void
printvec(int x)1359 printvec(int x)
1360 {
1361 int len,
1362 i;
1363
1364 output_str(output_stream, "#(");
1365 len = cdr(x);
1366
1367 for (i = 0; i < len; i++) {
1368 print(GET_VEC_ELT(x, i));
1369 if (i != len - 1) {
1370 output_char(output_stream, ' ');
1371 }
1372 }
1373 output_char(output_stream, ')');
1374 }
1375
1376 void
printarray(int x)1377 printarray(int x)
1378 {
1379 int i,
1380 size,
1381 st,
1382 ls,
1383 dim;
1384
1385 st = ls = GET_CDR(x);
1386 size = 1;
1387 dim = length(ls);
1388 while (!nullp(ls)) {
1389 size = GET_INT(car(ls)) * size;
1390 ls = cdr(ls);
1391 }
1392 ls = NIL;
1393 for (i = 0; i < size; i++)
1394 ls = cons(GET_VEC_ELT(x, i), ls);
1395 ls = reverse(ls);
1396 if (GET_OPT(output_stream) != EISL_INSTR)
1397 Fmt_fprint(GET_PORT(output_stream), "#%da", dim);
1398 else {
1399 char str[SHORT_STRSIZE];
1400 Fmt_sfmt(str, SHORT_STRSIZE, "#%da", dim);
1401 append_str(output_stream, str);
1402 }
1403 if (dim == 0)
1404 print(car(ls));
1405 else
1406 print(structured(ls, st));
1407 }
1408
1409
1410 void
printstr(int addr)1411 printstr(int addr)
1412 {
1413 if (GET_OPT(output_stream) != EISL_OUTSTR) {
1414 Fmt_fprint(GET_PORT(output_stream), "\"%s\"", GET_NAME(addr));
1415 } else {
1416 Fmt_sfmt(stream_str, STRSIZE, "\"%s\"", GET_NAME(addr));
1417 append_str(output_stream, stream_str);
1418 }
1419 }
1420
1421 void
printchar(int addr)1422 printchar(int addr)
1423 {
1424 output_str(output_stream, "#\\");
1425 switch (GET_CHAR(addr)) {
1426 case SPACE:
1427 output_str(output_stream, "space");
1428 break;
1429 case EOL:
1430 output_str(output_stream, "newline");
1431 break;
1432 default:
1433 output_str(output_stream, GET_NAME(addr));
1434 }
1435 }
1436
1437 void
printsym(int addr)1438 printsym(int addr)
1439 {
1440 output_str(output_stream, GET_NAME(addr));
1441 }
1442
1443 void
printobj(const char * str)1444 printobj(const char *str)
1445 {
1446 output_str(output_stream, str);
1447 }
1448
1449 void
printclass(int addr)1450 printclass(int addr)
1451 {
1452 if (GET_OPT(output_stream) != EISL_OUTSTR)
1453 Fmt_fprint(GET_PORT(output_stream), "<class %s>", GET_NAME(addr));
1454 else {
1455 Fmt_sfmt(stream_str, STRSIZE, "<class %s>", GET_NAME(addr));
1456 append_str(output_stream, stream_str);
1457 }
1458 }
1459
1460 void
printstream(int addr)1461 printstream(int addr)
1462 {
1463 const char *name;
1464
1465 REQUIRE(GET_TAG(addr) == STREAM);
1466 const signed char opt = GET_OPT(addr);
1467 if (opt == EISL_OUTSTR || opt == EISL_INSTR) {
1468 name = "<string>";
1469 } else {
1470 name = GET_NAME(addr);
1471 }
1472 if (GET_OPT(output_stream) != EISL_OUTSTR)
1473 Fmt_fprint(GET_PORT(output_stream), "<stream %s>", name);
1474 else {
1475 Fmt_sfmt(GET_NAME(output_stream), STRSIZE, "<stream %s>", name);
1476 append_str(output_stream, stream_str);
1477 }
1478 }
1479
1480 static void
clean_stdin(void)1481 clean_stdin(void)
1482 {
1483 int c;
1484 do {
1485 c = getchar();
1486 } while (c != '\n' && c != EOF);
1487 }
1488
1489 // --------eval---------------
1490 int
eval(int addr)1491 eval(int addr)
1492 {
1493 int val,
1494 res,
1495 temp;
1496 char c;
1497
1498 (void) checkgbc();
1499
1500 if (IS_NIL(addr) || IS_T(addr))
1501 return (addr);
1502 else if (numberp(addr))
1503 return (addr);
1504 else if (vectorp(addr))
1505 return (addr);
1506 else if (arrayp(addr))
1507 return (addr);
1508 else if (stringp(addr))
1509 return (addr);
1510 else if (charp(addr))
1511 return (addr);
1512 else if (symbolp(addr)) {
1513 res = findenv(addr);
1514 if (res != FAILSE)
1515 return (res);
1516 else {
1517 if (GET_OPT(addr) == GLOBAL)
1518 return (GET_CDR(addr));
1519 else if (GET_OPT(addr) == CONSTN)
1520 return (GET_CDR(addr));
1521 else
1522 error(UNDEF_VAR, "eval", addr);
1523
1524 }
1525 } else if (listp(addr)) {
1526 if (back_flag)
1527 store_backtrace(addr);
1528 if (stepper_flag) {
1529 print(addr);
1530 putchar('\n');
1531 clean_stdin();
1532 c = getc(stdin);
1533 if (c == 'q')
1534 debugger();
1535 }
1536
1537 if ((symbolp(car(addr))) && (HAS_NAME(car(addr), "QUOTE"))) {
1538 if (improper_list_p(cdr(addr)))
1539 error(ILLEGAL_ARGS, "quote", cdr(addr));
1540 else if (length(cdr(addr)) != 1)
1541 error(ILLEGAL_ARGS, "quote", cdr(addr));
1542 else
1543 return (cadr(addr));
1544 } else if ((symbolp(car(addr)))
1545 && (HAS_NAME(car(addr), "QUASI-QUOTE"))) {
1546 temp = quasi_transfer(cadr(addr), 0);
1547 shelterpush(temp);
1548 res = eval(temp);
1549 shelterpop();
1550 return (res);
1551 } else if (subrp(car(addr)))
1552 return (apply(caar(addr), evlis(cdr(addr))));
1553 else if (fsubrp(car(addr)))
1554 return (apply(caar(addr), cdr(addr)));
1555 else if ((val = functionp(car(addr)))) {
1556 if (GET_CDR(car(addr)) != NIL)
1557 error(UNDEF_FUN, "eval", addr);
1558 temp = evlis(cdr(addr));
1559 examin_sym = car(addr);
1560 return (apply(val, temp));
1561 } else if (macrop(car(addr))) {
1562 examin_sym = car(addr);
1563 return (apply(caar(addr), cdr(addr)));
1564 } else if (genericp(car(addr))) {
1565 examin_sym = car(addr);
1566 return (apply(caar(addr), evlis(cdr(addr))));
1567 } else if (listp(car(addr)))
1568 return (apply(eval(car(addr)), evlis(cdr(addr))));
1569 else
1570 error(UNDEF_FUN, "eval", car(addr));
1571
1572 }
1573 error(UNDEF_FUN, "eval", addr);
1574 return (0);
1575 }
1576
DEF_GETTER(char,TR,trace,NIL)1577 DEF_GETTER(char, TR, trace, NIL)
1578 int apply(int func, int args)
1579 {
1580 int varlist,
1581 body,
1582 res,
1583 i,
1584 n,
1585 pexist,
1586 qexist,
1587 trace;
1588 REQUIRE((GET_TAG(func) == FSUBR || GET_TAG(func) == SUBR
1589 || GET_TAG(func) == FUNC || GET_TAG(func) == MACRO
1590 || GET_TAG(func) == GENERIC) && (GET_TAG(args) == LIS
1591 || GET_TAG(args) == SYM));
1592 res = NIL;
1593 pexist = 0;
1594 qexist = 0;
1595 trace = 0;
1596
1597 switch (GET_TAG(func)) {
1598 case SUBR:
1599 return ((GET_SUBR(func)) (args));
1600 case FSUBR:
1601 return ((GET_SUBR(func)) (args));
1602 case FUNC:
1603 if (GET_TR(examin_sym) == 1) {
1604 trace = examin_sym;
1605 n = GET_TR(func);
1606 SET_TR(func, n + 1);
1607 for (i = 0; i < n; i++)
1608 putchar(' ');
1609 fputs("ENTERING: ", stdout);
1610 print(trace);
1611 putchar(' ');
1612 print(args);
1613 putchar('\n');
1614 }
1615 shelterpush(func);
1616 shelterpush(args);
1617 push(ep);
1618 ep = GET_CDR(func);
1619
1620 // if lambda is generated during eval method, lambda saved method
1621 // and argument
1622 // restore the method and argument.
1623 if (GET_PROP(func) != NIL) {
1624 next_method = car(GET_PROP(func));
1625 generic_vars = cdr(GET_PROP(func));
1626 generic_func = T; // to avoid error check in
1627 // (call-next-method)
1628 }
1629
1630 varlist = car(GET_CAR(func));
1631 if (GET_OPT(func) >= 0) {
1632 if (length(args) != (int) GET_OPT(func))
1633 error(WRONG_ARGS, GET_NAME(func), args);
1634 } else {
1635 if (length(args) < (-1 * (int) GET_OPT(func) - 2))
1636 error(WRONG_ARGS, GET_NAME(func), args);
1637 }
1638 body = cdr(GET_CAR(func));
1639 bindarg(varlist, args);
1640 while (!(IS_NIL(body))) {
1641 res = eval(car(body));
1642 body = cdr(body);
1643 }
1644 unbind();
1645 if (trace != NIL) {
1646 n = GET_TR(func);
1647 n = n - 1;
1648 SET_TR(func, n);
1649 for (i = 0; i < n; i++)
1650 putchar(' ');
1651 fputs("EXITING: ", stdout);
1652 print(trace);
1653 putchar(' ');
1654 print(res);
1655 putchar('\n');
1656 }
1657 shelterpop();
1658 shelterpop();
1659 ep = pop();
1660 return (res);
1661 case MACRO:{
1662 int macrofunc;
1663
1664 if (improper_list_p(args))
1665 error(IMPROPER_ARGS, "apply", args);
1666 macrofunc = GET_CAR(func);
1667 varlist = car(GET_CAR(macrofunc));
1668 if (GET_OPT(func) >= 0) {
1669 if (length(args) != (int) GET_OPT(func))
1670 error(WRONG_ARGS, GET_NAME(func), args);
1671 } else {
1672 if (length(args) < (-1 * (int) GET_OPT(func) - 2))
1673 error(WRONG_ARGS, GET_NAME(func), args);
1674 }
1675 body = cdr(GET_CAR(macrofunc));
1676 bindarg(varlist, args);
1677 while (!(IS_NIL(body))) {
1678 shelterpush(body);
1679 res = eval(car(body));
1680 shelterpop();
1681 body = cdr(body);
1682 }
1683 unbind();
1684 shelterpush(res);
1685 res = eval(res);
1686 shelterpop();
1687 return (res);
1688 }
1689
1690 case GENERIC:{
1691 int save1,
1692 save2,
1693 save3;
1694
1695 if (GET_OPT(func) >= 0) {
1696 if (length(args) != (int) GET_OPT(func))
1697 error(WRONG_ARGS, GET_NAME(func), args);
1698 } else {
1699 if (length(args) < (-1 * (int) GET_OPT(func) - 2))
1700 error(WRONG_ARGS, GET_NAME(func), args);
1701 }
1702 save1 = generic_func;
1703 save2 = generic_vars;
1704 save3 = next_method;
1705 generic_func = func;
1706 generic_vars = args;
1707 next_method = GET_CDR(func);
1708 if (GET_TR(examin_sym) == 1) {
1709 trace = examin_sym;
1710 n = GET_TR(func);
1711 SET_TR(func, n + 1);
1712 for (i = 0; i < n; i++)
1713 putchar(' ');
1714 fputs("ENTERING: ", stdout);
1715 print(trace);
1716 putchar(' ');
1717 print(args);
1718 putchar('\n');
1719 }
1720 while (!nullp(next_method)) {
1721 varlist = car(GET_CAR(car(next_method)));
1722 // adaptp(x,y) if sameclass or y is super-classs return 1
1723 // else 0;
1724 if (adaptp(varlist, args)) {
1725 // if only qualifier or sameclass-primary, eval
1726 // method;
1727 if ((GET_OPT(car(next_method)) == AROUND
1728 || GET_OPT(car(next_method)) == BEFORE
1729 || GET_OPT(car(next_method)) == AFTER)
1730 || (GET_OPT(car(next_method)) == PRIMARY
1731 && matchp(varlist, args) && pexist == 0)) {
1732
1733 if (GET_OPT(car(next_method)) == PRIMARY) {
1734 // primary method must executes only once.
1735 if (pexist == 1) {
1736 goto exit;
1737 }
1738 pexist = 1;
1739 } else {
1740 qexist = 1;
1741 }
1742 varlist = genlamlis_to_lamlis(varlist);
1743 body = cdr(GET_CAR(car(next_method)));
1744 multiple_call_next_method =
1745 has_multiple_call_next_method_p(body);
1746 bindarg(varlist, args);
1747 while (!nullp(body)) {
1748 res = eval(car(body));
1749 body = cdr(body);
1750 }
1751 unbind();
1752 }
1753 if (GET_OPT(car(next_method)) == AROUND) {
1754 goto exit;
1755 }
1756 }
1757 next_method = cdr(next_method);
1758 }
1759 if (pexist == 0 && qexist == 0) {
1760 error(NOT_EXIST_METHOD, GET_NAME(generic_func), args);
1761 }
1762 exit:
1763 generic_func = save1;
1764 generic_vars = save2;
1765 next_method = save3;
1766 return (res);
1767 }
1768 default:
1769 error(NOT_FUNC, "apply", list2(func, args));
1770 }
1771 return (0);
1772 }
1773
1774 void
bindarg(int varlist,int arglist)1775 bindarg(int varlist, int arglist)
1776 {
1777 int arg1,
1778 arg2;
1779
1780 push(ep);
1781 while (!(IS_NIL(varlist))) {
1782 if (cddr(varlist) == NIL && (car(varlist) == makesym(":REST")
1783 || car(varlist) == makesym("&REST"))) {
1784 arg1 = cadr(varlist);
1785 arg2 = arglist;
1786 addlexenv(arg1, arg2);
1787 return;
1788 } else {
1789 arg1 = car(varlist);
1790 arg2 = car(arglist);
1791 addlexenv(arg1, arg2);
1792 varlist = cdr(varlist);
1793 arglist = cdr(arglist);
1794 }
1795 }
1796 }
1797
1798 void
unbind(void)1799 unbind(void)
1800 {
1801 ep = pop();
1802 }
1803
1804
1805 int
evlis(int addr)1806 evlis(int addr)
1807 {
1808 argpush(addr);
1809 top_flag = false;
1810 if (IS_NIL(addr)) {
1811 argpop();
1812 return (addr);
1813 } else {
1814 int car_addr,
1815 cdr_addr;
1816
1817 car_addr = eval(car(addr));
1818 argpush(car_addr);
1819 cdr_addr = evlis(cdr(addr));
1820 car_addr = argpop();
1821 (void) argpop();
1822 return (cons(car_addr, cdr_addr));
1823 }
1824 }
1825
1826 /*
1827 * check class matching of argument of lambda and received argument.
1828 * if sameclass or varlist is super-class of arglist return 1, else return 0.
1829 */
1830 int
adaptp(int varlist,int arglist)1831 adaptp(int varlist, int arglist)
1832 {
1833
1834 if (nullp(varlist) && nullp(arglist))
1835 return (1);
1836 else if (symbolp(car(varlist)))
1837 return (adaptp(cdr(varlist), cdr(arglist)));
1838 else if (eqp(makesym(":rest"), car(varlist)))
1839 return (1);
1840 else if (eqp(makesym("&rest"), car(varlist)))
1841 return (1);
1842 else if (GET_AUX(cadar(varlist)) == GET_AUX(car(arglist))) // equal
1843 // class
1844 return (adaptp(cdr(varlist), cdr(arglist)));
1845 else if (subclassp(GET_AUX(car(arglist)), GET_AUX(cadar(varlist)))) // subclass
1846 return (adaptp(cdr(varlist), cdr(arglist)));
1847 else
1848 return (0);
1849 }
1850
1851
1852 /*
1853 * check class matching of argument of lambda and received argument.
1854 * only if same class return 1 else return 0.
1855 * built-in class, if varlist is subclass of arglist return 1.
1856 */
1857 int
matchp(int varlist,int arglist)1858 matchp(int varlist, int arglist)
1859 {
1860
1861 if (nullp(varlist) && nullp(arglist))
1862 return (1);
1863 else if (symbolp(car(varlist)))
1864 return (matchp(cdr(varlist), cdr(arglist)));
1865 else if (eqp(makesym(":rest"), car(varlist)))
1866 return (1);
1867 else if (eqp(makesym("&rest"), car(varlist)))
1868 return (1);
1869 else if (GET_AUX(cadar(varlist)) == GET_AUX(car(arglist))) // match
1870 // class
1871 return (matchp(cdr(varlist), cdr(arglist)));
1872 // when built-in class, subclass is also eqclass.
1873 else if (GET_OPT(cadar(varlist)) == SYSTEM
1874 && subclassp(GET_AUX(car(arglist)), GET_AUX(cadar(varlist))))
1875 return (matchp(cdr(varlist), cdr(arglist)));
1876 else
1877 return (0);
1878 }
1879
1880
1881
1882 /*
1883 * change lambda list of function to normal argument. ex ((x <number>)(y
1884 * <list>)) -> (x y)
1885 */
1886 int
genlamlis_to_lamlis(int varlist)1887 genlamlis_to_lamlis(int varlist)
1888 {
1889 int res;
1890
1891 res = NIL;
1892 while (!nullp(varlist)) {
1893 if (symbolp(car(varlist)))
1894 res = cons(car(varlist), res);
1895 else
1896 res = cons(caar(varlist), res);
1897
1898 varlist = cdr(varlist);
1899 }
1900 return (reverse(res));
1901 }
1902
1903
1904 // for stack to store ep(environment)
1905 int
push(int pt)1906 push(int pt)
1907 {
1908 if (sp >= STACKSIZE)
1909 error(STACK_OVERF, "push", NIL);
1910 stack[sp++] = pt;
1911
1912 return (T);
1913 }
1914
1915 int
pop(void)1916 pop(void)
1917 {
1918 if (sp <= 0)
1919 error(STACK_UNDERF, "pop", NIL);
1920 return (stack[--sp]);
1921 }
1922
1923 // push/pop of arglist
1924 int
argpush(int addr)1925 argpush(int addr)
1926 {
1927 argstk[ap++] = addr;
1928
1929 return (T);
1930 }
1931
1932 int
argpop(void)1933 argpop(void)
1934 {
1935 return (argstk[--ap]);
1936 }
1937
1938 // shelter push/pop
1939 int
shelterpush(int addr)1940 shelterpush(int addr)
1941 {
1942 if (lp >= STACKSIZE)
1943 error(SHELTER_OVERF, "shelterpush", NIL);
1944 shelter[lp++] = addr;
1945
1946 return (T);
1947 }
1948
1949 int
shelterpop(void)1950 shelterpop(void)
1951 {
1952 if (lp <= 0)
1953 error(SHELTER_UNDERF, "shelterpop", NIL);
1954 return (shelter[--lp]);
1955 }
1956
1957 // --------system function
1958 // regist subr to environment.
1959 void
defsubr(const char * symname,int (* func)(int))1960 defsubr(const char *symname, int (*func)(int))
1961 {
1962 bindfunc(symname, SUBR, func);
1963 }
1964
1965 // regist fsubr(not eval argument)
1966 void
deffsubr(const char * symname,int (* func)(int))1967 deffsubr(const char *symname, int (*func)(int))
1968 {
1969 bindfunc(symname, FSUBR, func);
1970 }
1971
1972
1973 static inline void
SET_SUBR(int addr,subr_t x)1974 SET_SUBR(int addr, subr_t x)
1975 {
1976 REQUIRE(CELLRANGE(addr) &&
1977 (GET_TAG(addr) == SUBR || GET_TAG(addr) == FSUBR));
1978 heap[addr].val.car.subr = x;
1979 }
1980
1981 void
bindfunc(const char * name,tag_t tag,int (* func)(int))1982 bindfunc(const char *name, tag_t tag, int (*func)(int))
1983 {
1984 int sym,
1985 val;
1986
1987 sym = makesym(name);
1988 val = freshcell();
1989 SET_TAG(val, tag);
1990 SET_SUBR(val, func);
1991 SET_CDR(val, 0);
1992 SET_AUX(val, cfunction); // class function
1993 SET_CAR(sym, val);
1994 }
1995
1996 void
bindmacro(char * name,int addr)1997 bindmacro(char *name, int addr)
1998 {
1999 int sym,
2000 val1,
2001 val2;
2002
2003 sym = makesym(name);
2004 val1 = freshcell();
2005 SET_TAG(val1, FUNC);
2006 SET_CAR(val1, addr);
2007 SET_CDR(val1, 0);
2008 val2 = freshcell();
2009 SET_TAG(val2, MACRO);
2010 TRY heap[val2].name = Str_dup(name, 1, 0, 1);
2011 EXCEPT(Mem_Failed)
2012 error(MALLOC_OVERF, "makemacro", NIL);
2013 END_TRY;
2014 SET_CAR(val2, val1);
2015 SET_CDR(val2, 0);
2016 SET_AUX(val2, cfunction); // class
2017 SET_OPT(val2, (signed char) count_args(car(addr))); // count of args
2018 SET_CAR(sym, val2);
2019 }
2020
2021 void
bindconst(const char * name,int obj)2022 bindconst(const char *name, int obj)
2023 {
2024 int sym;
2025
2026 sym = makesym(name);
2027 SET_CDR(sym, obj);
2028 SET_OPT(sym, CONSTN);
2029 }
2030
2031 // --------qusi quote---------------
2032 int
quasi_transfer(int x,int n)2033 quasi_transfer(int x, int n)
2034 {
2035 // printf("%d",n); print(x);putchar('\n');
2036
2037 if (nullp(x))
2038 return (NIL);
2039 else if (atomp(x))
2040 return (list2(makesym("QUOTE"), x));
2041 else if (listp(x) && eqp(car(x), makesym("UNQUOTE")) && n == 0)
2042 return (cadr(x));
2043 else if (listp(x) && eqp(car(x), makesym("UNQUOTE-SPLICING"))
2044 && n == 0)
2045 return (cadr(x));
2046 else if (listp(x) && eqp(car(x), makesym("QUASI-QUOTE")))
2047 return (list3(makesym("LIST"),
2048 list2(makesym("QUOTE"), makesym("QUASI-QUOTE")),
2049 quasi_transfer(cadr(x), n + 1)));
2050 else if (listp(x) && eqp(caar(x), makesym("UNQUOTE")) && n == 0)
2051 return (list3
2052 (makesym("CONS"), cadar(x), quasi_transfer(cdr(x), n)));
2053 else if (listp(x) && eqp(caar(x), makesym("UNQUOTE-SPLICING"))
2054 && n == 0)
2055 return (list3
2056 (makesym("APPEND"), cadar(x), quasi_transfer(cdr(x), n)));
2057 else if (listp(x) && eqp(caar(x), makesym("UNQUOTE")))
2058 return (list3(makesym("CONS"),
2059 list3(makesym("LIST"),
2060 list2(makesym("QUOTE"), makesym("UNQUOTE")),
2061 quasi_transfer(cadar(x), n - 1)),
2062 quasi_transfer(cdr(x), n)));
2063 else if (listp(x) && eqp(caar(x), makesym("UNQUOTE-SPLICING")))
2064 return (list3(makesym("CONSc"),
2065 list3(makesym("LIST"),
2066 list2(makesym("QUOTE"),
2067 makesym("UNQUOTE-SPLICING")),
2068 quasi_transfer(cadar(x), n - 1)),
2069 quasi_transfer(cdr(x), n)));
2070 else
2071 return (list3
2072 (makesym("CONS"), quasi_transfer(car(x), n),
2073 quasi_transfer(cdr(x), n)));
2074 }
2075
2076 // --------debug---------------
2077 void
debugger()2078 debugger()
2079 {
2080 int i;
2081
2082 puts("debug mode ?(help)");
2083 while (1) {
2084 fputs(">>", stdout);
2085 int x = sread();
2086 if (eqp(x, makesym("?"))) {
2087 puts("? help\n"
2088 ":a abort\n"
2089 ":b backtrace\n"
2090 ":d dynamic environment\n"
2091 ":e environment\n"
2092 ":i identify examining symbol\n"
2093 ":q quit\n"
2094 ":r room\n" ":s stepper ON/OFF\n" "other S exps eval");
2095 } else if (eqp(x, makesym(":A"))) {
2096 RAISE(Restart_Repl);
2097 } else if (eqp(x, makesym(":B"))) {
2098 for (i = 0; i < BACKSIZE; i++) {
2099 print(backtrace[i]);
2100 putchar('\n');
2101 }
2102 } else if (eqp(x, makesym(":D"))) {
2103 #ifdef DYN
2104 for (i = 1; i <= dp; i++) {
2105 print(dynamic[i][1]);
2106 fputs(" = ", stdout);
2107 print(dynamic[1][1]);
2108 putchar('\n');
2109 }
2110 #else
2111 print(dp);
2112 putchar('\n');
2113 #endif
2114 } else if (eqp(x, makesym(":E"))) {
2115 print(ep);
2116 putchar('\n');
2117 } else if (eqp(x, makesym(":I"))) {
2118 print(examin_sym);
2119 putchar('\n');
2120 } else if (eqp(x, makesym(":Q"))) {
2121 return;
2122 } else if (eqp(x, makesym(":R"))) {
2123 Fmt_print("EP = %d (environment pointer)\n"
2124 "DP = %d (dynamic pointer)\n"
2125 "HP = %d (heap pointer)\n"
2126 "SP = %d (stack pointer)\n"
2127 "FC = %d (free counter)\n"
2128 "AP = %d (arglist pointer)\n"
2129 "LP = %d (shelter pointer)\n"
2130 "GC = %d (GC switch 0=m&sGC 1=copyGC)\n"
2131 "WP = %d (work area pointer)\n"
2132 "SW = %d (current work area 1or2)\n",
2133 ep, dp, hp, sp, fc, ap, lp, gc_sw, wp, area_sw);
2134 } else if (eqp(x, makesym(":S"))) {
2135 if (stepper_flag == 0) {
2136 puts("stepper ON. enter 'q' to quit stepper");
2137 stepper_flag = 1;
2138 } else {
2139 puts("stepper OFF");
2140 stepper_flag = 0;
2141 }
2142 } else {
2143 print(eval(x));
2144 putchar('\n');
2145 }
2146 }
2147 }
2148