1 #include <stdio.h>
2 #include <string.h>
3 #include <ctype.h>
4 #include <stdlib.h>
5 #include <float.h>
6 #include "eisl.h"
7 #include "mem.h"
8 #include "fmt.h"
9 #include "eiffel.h"
10
11 int
get_int(int addr)12 get_int(int addr)
13 {
14 return (GET_INT(addr));
15 }
16
17 long long int
get_long(int addr)18 get_long(int addr)
19 {
20 return (GET_LONG(addr));
21 }
22
23 int
atomp(int addr)24 atomp(int addr)
25 {
26 if (!(IS_LIST(addr)))
27 return (1);
28 else
29 return (0);
30 }
31
32 int
numberp(int addr)33 numberp(int addr)
34 {
35 if (IS_INTEGER(addr) || IS_FLOAT(addr) || IS_LONGNUM(addr)
36 || IS_BIGXNUM(addr))
37 return (1);
38 else
39 return (0);
40 }
41
42 int
integerp(int x)43 integerp(int x)
44 {
45 if (IS_INTEGER(x))
46 return (1);
47 else
48 return (0);
49 }
50
51 int
bignump(int x)52 bignump(int x)
53 {
54 if (IS_BIGXNUM(x))
55 return (1);
56 else
57 return (0);
58 }
59
60 int
longnump(int x)61 longnump(int x)
62 {
63 if (IS_LONGNUM(x))
64 return (1);
65 else
66 return (0);
67 }
68
69 int
floatp(int x)70 floatp(int x)
71 {
72 if (IS_FLOAT(x))
73 return (1);
74 else
75 return (0);
76 }
77
78 int
math_integerp(int addr)79 math_integerp(int addr)
80 {
81 if (IS_INTEGER(addr) || IS_LONGNUM(addr) || IS_BIGXNUM(addr))
82 return (1);
83 else
84 return (0);
85 }
86
87
DEF_PREDICATE(SYMBOL,SYM)88 DEF_PREDICATE(SYMBOL, SYM)
89 int symbolp(int addr)
90 {
91 if (IS_SYMBOL(addr))
92 return (1);
93 else
94 return (0);
95 }
96
97 int
listp(int addr)98 listp(int addr)
99 {
100 if (IS_LIST(addr) || IS_NIL(addr))
101 return (1);
102 else
103 return (0);
104 }
105
106 int
nullp(int addr)107 nullp(int addr)
108 {
109 if (IS_NIL(addr))
110 return (1);
111 else
112 return (0);
113 }
114
115 int
eqp(int addr1,int addr2)116 eqp(int addr1, int addr2)
117 {
118 if (addr1 == addr2)
119 return (1);
120 else
121 return (0);
122 }
123
124 int
eqlp(int addr1,int addr2)125 eqlp(int addr1, int addr2)
126 {
127 int i,
128 n,
129 ls;
130
131 if (addr1 == addr2)
132 return (1);
133 else if (numberp(addr1) && numberp(addr2) && math_integerp(addr1)
134 && math_integerp(addr2))
135 return (numeqp(addr1, addr2));
136 else if (numberp(addr1) && numberp(addr2) && floatp(addr1)
137 && floatp(addr2))
138 return (numeqp(addr1, addr2));
139 else if (((symbolp(addr1) && symbolp(addr2)))
140 && (SAME_NAME(addr1, addr2)))
141 return (1);
142 else if (((charp(addr1) && charp(addr2)))
143 && (SAME_NAME(addr1, addr2)))
144 return (1);
145 else if (((stringp(addr1) && stringp(addr2)))
146 && (SAME_NAME(addr1, addr2)))
147 return (1);
148 else if (vectorp(addr1) && vectorp(addr2)) {
149 if (vector_length(addr1) == vector_length(addr2)) {
150 n = vector_length(addr1);
151 for (i = 0; i < n; i++)
152 if (!eqlp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
153 return (0);
154 return (1);
155 } else
156 return (0);
157 } else if (arrayp(addr1) && arrayp(addr2)) {
158 if (equalp(array_length(addr1), array_length(addr2))) {
159 ls = array_length(addr1);
160 n = 1;
161 while (!nullp(ls)) {
162 n = n * GET_INT(car(ls));
163 ls = cdr(ls);
164 }
165 for (i = 0; i < n; i++)
166 if (!eqlp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
167 return (0);
168 return (1);
169 } else
170 return (0);
171 }
172 return (0);
173 }
174
175 int
equalp(int addr1,int addr2)176 equalp(int addr1, int addr2)
177 {
178 if (vectorp(addr1) && vectorp(addr2)) {
179 if (vector_length(addr1) == vector_length(addr2)) {
180 int i,
181 n;
182
183 n = vector_length(addr1);
184 for (i = 0; i < n; i++) {
185 if (!equalp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
186 return (0);
187 }
188 return (1);
189 } else
190 return (0);
191 } else if (atomp(addr1) && atomp(addr2))
192 return (eqlp(addr1, addr2));
193 else if (atomp(addr1) && !atomp(addr2))
194 return (0);
195 else if (!atomp(addr1) && atomp(addr2))
196 return (0);
197 else if (equalp(car(addr1), car(addr2)) &&
198 equalp(cdr(addr1), cdr(addr2)))
199 return (1);
200 else
201 return (0);
202
203 }
204
205 int
subrp(int addr)206 subrp(int addr)
207 {
208
209 if (IS_SUBR(GET_CAR(addr)))
210 return (1);
211 else
212 return (0);
213 }
214
215 int
fsubrp(int addr)216 fsubrp(int addr)
217 {
218
219 if (IS_FSUBR(GET_CAR(addr)))
220 return (1);
221 else
222 return (0);
223 }
224
225 int
functionp(int addr)226 functionp(int addr)
227 {
228 int val;
229
230 val = finddyn(addr);
231 if ((val != -1) && IS_FUNC(val))
232 return (val);
233 val = findenv(addr);
234 if ((val != FAILSE) && IS_FUNC(val))
235 return (val);
236 val = GET_CAR(addr);
237 if (IS_FUNC(val))
238 return (val);
239 else
240 return (0);
241 }
242
243 int
macrop(int addr)244 macrop(int addr)
245 {
246 if (!CELLRANGE(addr))
247 return (0);
248 else if (!CELLRANGE(GET_CAR(addr)))
249 return (0);
250 else if (IS_MACRO(GET_CAR(addr)))
251 return (1);
252 else
253 return (0);
254 }
255
256 int
genericp(int addr)257 genericp(int addr)
258 {
259
260 if (IS_GENERIC(GET_CAR(addr)))
261 return (1);
262 else
263 return (0);
264
265 }
266
267 int
stringp(int x)268 stringp(int x)
269 {
270 if (IS_STRING(x))
271 return (1);
272 else
273 return (0);
274 }
275
276
DEF_PREDICATE(CHARACTER,CHR)277 DEF_PREDICATE(CHARACTER, CHR)
278 int charp(int x)
279 {
280 if (IS_CHARACTER(x))
281 return (1);
282 else
283 return (0);
284 }
285
286 int
vectorp(int x)287 vectorp(int x)
288 {
289 if (IS_VECTOR(x))
290 return (1);
291 else
292 return (0);
293 }
294
295 int
arrayp(int x)296 arrayp(int x)
297 {
298 if (IS_ARRAY(x))
299 return (1);
300 else
301 return (0);
302 }
303
304
DEF_PREDICATE(STREAM,STREAM)305 DEF_PREDICATE(STREAM, STREAM)
306 int streamp(int x)
307 {
308 if (IS_STREAM(x))
309 return (1);
310 else
311 return (0);
312 }
313
314 int
input_stream_p(int x)315 input_stream_p(int x)
316 {
317 if (streamp(x)
318 && (GET_OPT(x) == EISL_INPUT || GET_OPT(x) == EISL_INSTR))
319 return (1);
320 else
321 return (0);
322 }
323
324 int
output_stream_p(int x)325 output_stream_p(int x)
326 {
327 if (streamp(x)
328 && (GET_OPT(x) == EISL_OUTPUT || GET_OPT(x) == EISL_OUTSTR))
329 return (1);
330 else
331 return (0);
332 }
333
334 int
class_symbol_p(int x)335 class_symbol_p(int x)
336 {
337 if (IS_SYMBOL(x) && GET_OPT(x) == SYSTEM)
338 return (1);
339 else
340 return (0);
341 }
342
343 int
classp(int x)344 classp(int x)
345 {
346 if (IS_CLASS(x))
347 return (1);
348 else
349 return (0);
350 }
351
352 int
subclassp(int x,int y)353 subclassp(int x, int y)
354 {
355 if (x == y)
356 return (0);
357 else if (y == cobject)
358 return (1);
359 else
360 return (subclassp1(x, y));
361 }
362
363 int
subclassp1(int x,int y)364 subclassp1(int x, int y)
365 {
366 if (nullp(x))
367 return (0);
368 else if (atomp(x)) {
369 if (x == y)
370 return (1);
371 else if (GET_OPT(x) == USER && y == cstandard_object)
372 return (1);
373 else if (GET_OPT(x) == USER && GET_OPT(y) == SYSTEM) {
374 x = cstandard_class;
375 return (subclassp1(x, y));
376 } else if (symbolp(x))
377 return (subclassp1(GET_AUX(x), y));
378 else if (GET_CAR(x) == NIL)
379 return (0);
380 else
381 return (subclassp1(GET_CAR(x), y));
382 } else {
383 if (subclassp1(car(x), y) || subclassp1(cdr(x), y))
384 return (1);
385 else
386 return (0);
387 }
388 }
389
390 int
has_common_p(int ls)391 has_common_p(int ls)
392 {
393 if (length(ls) < 2)
394 return (0);
395
396 while (!nullp(cdr(ls))) {
397 if (has_common_p1(car(ls), cadr(ls)))
398 return (1);
399 else
400 ls = cdr(ls);
401 }
402 return (0);
403 }
404
405 int
has_common_p1(int x,int y)406 has_common_p1(int x, int y)
407 {
408 if (includep(GET_CAR(GET_AUX(x)), GET_CAR(GET_AUX(y))))
409 return (1);
410 else if (y != cobject && y != cstandard_class && subclassp(x, y))
411 return (1);
412 else if (x != cobject && x != cstandard_class && subclassp(y, x))
413 return (1);
414 else
415 return (0);
416 }
417
418 int
includep(int x,int y)419 includep(int x, int y)
420 {
421 while (!nullp(x)) {
422 if (member(car(x), y))
423 return (1);
424 else
425 x = cdr(x);
426 }
427 return (0);
428 }
429
430 int
has_same_p(int ls)431 has_same_p(int ls)
432 {
433 while (!nullp(ls)) {
434 if (member(car(ls), cdr(ls)))
435 return (1);
436 else
437 ls = cdr(ls);
438 }
439 return (0);
440 }
441
442 int
has_sys_class_p(int ls)443 has_sys_class_p(int ls)
444 {
445 while (!nullp(ls)) {
446 if (GET_OPT(car(ls)) == SYSTEM)
447 return (1);
448 else
449 ls = cdr(ls);
450 }
451 return (0);
452 }
453
454 int
not_exist_class_p(int ls)455 not_exist_class_p(int ls)
456 {
457 while (!nullp(ls)) {
458 if (GET_AUX(car(ls)) == csymbol)
459 return (1);
460 else
461 ls = cdr(ls);
462 }
463 return (0);
464 }
465
466 int
illegal_lambda_p(int ls)467 illegal_lambda_p(int ls)
468 {
469 if (!listp(ls) && !nullp(ls))
470 return (1);
471
472 if (nullp(ls))
473 return (0);
474 else if (car(ls) == T)
475 return (1);
476 else if (car(ls) == NIL)
477 return (1);
478 else if (eqp(car(ls), makesym("*PI*")))
479 return (1);
480 else if (eqp(car(ls), makesym("*MOST-POSITIVE-FLOAT*")))
481 return (1);
482 else if (eqp(car(ls), makesym("*MOST-NEGATIVE-FLOAT*")))
483 return (1);
484 else if (eqp(car(ls), makesym(":REST"))
485 && member(makesym(":REST"), cdr(ls)))
486 return (1);
487 else if (eqp(car(ls), makesym("&REST"))
488 && member(makesym("&REST"), cdr(ls)))
489 return (1);
490 else if (eqp(car(ls), makesym(":REST"))
491 && member(makesym("&REST"), cdr(ls)))
492 return (1);
493 else if (eqp(car(ls), makesym("&REST"))
494 && member(makesym(":REST"), cdr(ls)))
495 return (1);
496 else if (symbolp(car(ls)) && !eqp(car(ls), makesym(":REST"))
497 && !eqp(car(ls), makesym("&REST"))
498 && (STRING_REF(car(ls), 0) == ':'
499 || STRING_REF(car(ls), 0) == '&'))
500 return (1);
501 else
502 return (illegal_lambda_p(cdr(ls)));
503
504 }
505
506 int
undef_parameter_p(int ls)507 undef_parameter_p(int ls)
508 {
509
510 if (nullp(ls))
511 return (0);
512 else if (symbolp(car(ls)))
513 return (undef_parameter_p(cdr(ls)));
514 else if (listp(car(ls))) {
515 // e.g. ((x undef)) undef is only symbol and it's class is (class
516 // <symbol>)
517 if (symbolp(cadar(ls)) && GET_AUX(cadar(ls)) == csymbol)
518 return (1);
519 else
520 return (undef_parameter_p(cdr(ls)));
521 } else
522 return (1);
523 }
524
525 int
unified_parameter_p(int lamlis,int ls)526 unified_parameter_p(int lamlis, int ls)
527 {
528
529 if (nullp(lamlis) && nullp(ls))
530 return (1);
531 else if (nullp(lamlis) && !nullp(ls))
532 return (0);
533 else if (!nullp(lamlis) && nullp(ls))
534 return (0);
535 else if ((eqp(car(lamlis), makesym(":REST"))
536 || eqp(car(lamlis), makesym("&REST")))
537 && (eqp(car(ls), makesym(":REST"))
538 || eqp(car(ls), makesym("&REST"))))
539 return (unified_parameter_p(cdr(lamlis), cdr(ls)));
540 else if (symbolp(car(lamlis)) && symbolp(car(ls)))
541 return (unified_parameter_p(cdr(lamlis), cdr(ls)));
542 else if (symbolp(car(lamlis))
543 && (listp(car(ls) && length(car(ls) == 2))))
544 return (unified_parameter_p(cdr(lamlis), cdr(ls)));
545 else if ((listp(car(lamlis)) && length(car(lamlis)) == 2)
546 && (listp(car(ls) && length(car(ls) == 2))))
547 return (unified_parameter_p(cdr(lamlis), cdr(ls)));
548 else
549 return (0);
550 /*
551 * check unification lambda-list of generic-function and
552 * method-parameter e.g. lambda-list=(x y :rest z) parameter= ((x
553 * <integer>)(y <float>) :rest (z <array))
554 *
555 */
556
557 }
558
559
560 int
improper_list_p(int ls)561 improper_list_p(int ls)
562 {
563 if (nullp(ls))
564 return (0);
565 else if (atomp(ls))
566 return (1);
567 else
568 return (improper_list_p(cdr(ls)));
569 }
570
571 int
duplicate_list_p(int ls)572 duplicate_list_p(int ls)
573 {
574 if (nullp(ls))
575 return (0);
576 else if (!eqp(car(ls), makesym("&REST"))
577 && !eqp(car(ls), makesym(":REST"))
578 && member(car(ls), cdr(ls)))
579 return (1);
580 else if (eqp(car(ls), makesym("&REST")) && nullp(cdr(ls)))
581 return (1);
582 else if (eqp(car(ls), makesym(":REST")) && nullp(cdr(ls)))
583 return (1);
584 else if (eqp(car(ls), makesym("&REST")) && length(cdr(ls)) > 1)
585 return (1);
586 else if (eqp(car(ls), makesym(":REST")) && length(cdr(ls)) > 1)
587 return (1);
588 else if (eqp(car(ls), makesym("&REST"))
589 || eqp(car(ls), makesym(":REST")))
590 return (duplicate_list_p(cddr(ls)));
591 else
592 return (duplicate_list_p(cdr(ls)));
593 }
594
595 int
symbol_list_p(int ls)596 symbol_list_p(int ls)
597 {
598 if (nullp(ls))
599 return (1);
600 else if (!symbolp(car(ls)))
601 return (0);
602 else if (eqp(car(ls), makesym("&REST")) && !symbolp(cadr(ls)))
603 return (0);
604 else if (eqp(car(ls), makesym(":REST")) && !symbolp(cadr(ls)))
605 return (0);
606 else
607 return (symbol_list_p(cdr(ls)));
608 }
609
610 int
has_multiple_call_next_method_p(int x)611 has_multiple_call_next_method_p(int x)
612 {
613 int count,
614 ls;
615
616 count = 0;
617 ls = x;
618
619 while (!nullp(ls)) {
620 if (has_multiple_call_next_method_p1(car(ls)))
621 count++;
622 if (has_multiple_call_next_method_p2(car(ls)))
623 return (1);
624
625 ls = cdr(ls);
626 }
627 if (count >= 2)
628 return (1);
629 else
630 return (0);
631 }
632
633 int
has_multiple_call_next_method_p1(int x)634 has_multiple_call_next_method_p1(int x)
635 {
636 if (nullp(x))
637 return (0);
638 else if (symbolp(x) && eqp(x, makesym("CALL-NEXT-METHOD")))
639 return (1);
640 else if (atomp(x))
641 return (0);
642 else if (has_multiple_call_next_method_p1(car(x))
643 || has_multiple_call_next_method_p1(cdr(x)))
644 return (1);
645 else
646 return (0);
647
648 }
649
650 // e.g. (list (call-next-method) (call-next-method))
651 int
has_multiple_call_next_method_p2(int x)652 has_multiple_call_next_method_p2(int x)
653 {
654 int count,
655 ls;
656
657 count = 0;
658 ls = x;
659 while (!nullp(ls)) {
660 if (has_multiple_call_next_method_p1(car(ls)))
661 count++;
662
663 ls = cdr(ls);
664 }
665 if (count >= 2)
666 return (1);
667 else
668 return (0);
669 }
670
671 // --------------list operation---------------------
672
673 int
car(int addr)674 car(int addr)
675 {
676 return (GET_CAR(addr));
677 }
678
679 int
caar(int addr)680 caar(int addr)
681 {
682 return (car(car(addr)));
683 }
684
685 int
cdar(int addr)686 cdar(int addr)
687 {
688 return (cdr(car(addr)));
689 }
690
691 int
cdr(int addr)692 cdr(int addr)
693 {
694 return (GET_CDR(addr));
695 }
696
697 int
cadr(int addr)698 cadr(int addr)
699 {
700 return (car(cdr(addr)));
701 }
702
703 int
cddr(int addr)704 cddr(int addr)
705 {
706 return (cdr(cdr(addr)));
707 }
708
709 int
caddr(int addr)710 caddr(int addr)
711 {
712 return (car(cdr(cdr(addr))));
713 }
714
715 int
cadar(int addr)716 cadar(int addr)
717 {
718 return (car(cdr(car(addr))));
719 }
720
721 int
cdddr(int addr)722 cdddr(int addr)
723 {
724 return (cdr(cdr(cdr(addr))));
725 }
726
727 int
caddar(int addr)728 caddar(int addr)
729 {
730 return (car(cdr(cdr(car(addr)))));
731 }
732
733 int
nth(int n,int addr)734 nth(int n, int addr)
735 {
736 while (n > 0) {
737 addr = cdr(addr);
738 n--;
739 }
740 return (car(addr));
741 }
742
743 int
cons(int car,int cdr)744 cons(int car, int cdr)
745 {
746 int addr;
747
748 addr = freshcell();
749 SET_TAG(addr, LIS);
750 SET_CAR(addr, car);
751 SET_CDR(addr, cdr);
752 SET_AUX(addr, ccons); // cons class
753 return (addr);
754 }
755
756 int
hcons(int car,int cdr)757 hcons(int car, int cdr)
758 {
759 int addr;
760
761 addr = hfreshcell();
762 SET_TAG(addr, LIS);
763 SET_CAR(addr, car);
764 SET_CDR(addr, cdr);
765 SET_AUX(addr, ccons); // cons class
766 return (addr);
767 }
768
769
770 int
length(int addr)771 length(int addr)
772 {
773 int len = 0;
774
775 while (!nullp(addr) && !atomp(addr)) {
776 len++;
777 addr = cdr(addr);
778 }
779 return (len);
780 }
781
782 int
list(int arglist)783 list(int arglist)
784 {
785 if (nullp(arglist))
786 return (NIL);
787 else
788 return (cons(car(arglist), list(cdr(arglist))));
789 }
790
791 int
assoc(int x,int y)792 assoc(int x, int y)
793 {
794 if (nullp(y))
795 return (0);
796 else if (eqlp(x, caar(y)))
797 return (car(y));
798 else
799 return (assoc(x, cdr(y)));
800 }
801
802 int
assq(int x,int y)803 assq(int x, int y)
804 {
805 if (nullp(y))
806 return (FAILSE);
807 else if (eqp(x, caar(y)))
808 return (car(y));
809 else
810 return (assq(x, cdr(y)));
811 }
812
813 int
assoclistp(int ls)814 assoclistp(int ls)
815 {
816 while (!nullp(ls)) {
817 if (!listp(car(ls)))
818 return (0);
819 else
820 ls = cdr(ls);
821 }
822 return (1);
823 }
824
825 int
member(int x,int y)826 member(int x, int y)
827 {
828 if (nullp(y))
829 return (NIL);
830 else if (equalp(x, car(y)))
831 return (y);
832 else
833 return (member(x, cdr(y)));
834 }
835
836 int
member1(int x,int y,int z)837 member1(int x, int y, int z)
838 {
839 if (nullp(y))
840 return (NIL);
841 else if (apply(z, list2(x, car(y))) != NIL)
842 return (y);
843 else
844 return (member1(x, cdr(y), z));
845 }
846
847 int
mapcar(int x,int y)848 mapcar(int x, int y)
849 {
850 int ls,
851 res;
852
853 ls = y;
854 shelterpush(y);
855 if (nullp(ls) || member(NIL, ls)) {
856 res = NIL;
857 } else {
858 res = cons(apply(x, each_car(y)), mapcar(x, each_cdr(y)));
859 }
860 shelterpop();
861 return res;
862 }
863
864 int
each_car(int x)865 each_car(int x)
866 {
867 REQUIRE(GET_TAG(x) == LIS || GET_TAG(x) == SYM);
868 if (nullp(x))
869 return (NIL);
870 else
871 return (cons(caar(x), each_car(cdr(x))));
872 }
873
874 int
each_cdr(int x)875 each_cdr(int x)
876 {
877 REQUIRE(GET_TAG(x) == LIS || GET_TAG(x) == SYM);
878 if (nullp(x))
879 return (NIL);
880 else
881 return (cons(cdar(x), each_cdr(cdr(x))));
882 }
883
884
885 int
mapc(int x,int y)886 mapc(int x, int y)
887 {
888 int ls;
889
890 ls = y;
891 shelterpush(y);
892 while (!member(NIL, ls)) {
893 shelterpush(ls);
894 apply(x, each_car(ls));
895 shelterpop();
896 ls = each_cdr(ls);
897 }
898 shelterpop();
899 return (car(y));
900 }
901
902 int
maplist(int x,int y)903 maplist(int x, int y)
904 {
905 if (member(NIL, y))
906 return (NIL);
907 else
908 return (cons(apply(x, y), maplist(x, maplist1(y))));
909 }
910
911 int
maplist1(int y)912 maplist1(int y)
913 {
914 int res;
915
916 res = NIL;
917 while (y != NIL) {
918 if (car(y) == NIL)
919 return (NIL);
920 res = cons(cdar(y), res);
921 y = cdr(y);
922 }
923 return (reverse(res));
924 }
925
926 int
mapl(int x,int y)927 mapl(int x, int y)
928 {
929 int res;
930
931 res = y;
932 while (!member(NIL, y)) {
933 apply(x, y);
934 y = maplist1(y);
935 }
936 return (car(res));
937 }
938
939 int
mapcon(int x,int y)940 mapcon(int x, int y)
941 {
942 int res;
943
944 if (member(NIL, y))
945 return (NIL);
946 res = apply(x, y);
947 y = maplist1(y);
948 while (!member(NIL, y)) {
949 res = nconc(res, apply(x, y));
950 y = maplist1(y);
951 }
952 return (res);
953 }
954
955
956 int
mapcan(int x,int y)957 mapcan(int x, int y)
958 {
959 int res;
960
961 if (member(NIL, y))
962 return (NIL);
963 res = apply(x, each_car(y));
964 y = each_cdr(y);
965 while (!member(NIL, y)) {
966 res = nconc(res, apply(x, each_car(y)));
967 y = each_cdr(y);
968 }
969 return (res);
970 }
971
972
973 // extension
974 int
list1(int x)975 list1(int x)
976 {
977 return (cons(x, NIL));
978 }
979
980 int
hlist1(int x)981 hlist1(int x)
982 {
983 return (hcons(x, NIL));
984 }
985
986 int
list2(int x,int y)987 list2(int x, int y)
988 {
989 return (cons(x, cons(y, NIL)));
990 }
991
992 int
list3(int x,int y,int z)993 list3(int x, int y, int z)
994 {
995 return (cons(x, cons(y, cons(z, NIL))));
996 }
997
998 int
list4(int x1,int x2,int x3,int x4)999 list4(int x1, int x2, int x3, int x4)
1000 {
1001 return (cons(x1, cons(x2, cons(x3, cons(x4, NIL)))));
1002 }
1003
1004 int
list6(int x1,int x2,int x3,int x4,int x5,int x6)1005 list6(int x1, int x2, int x3, int x4, int x5, int x6)
1006 {
1007 return (cons
1008 (x1, cons(x2, cons(x3, cons(x4, cons(x5, cons(x6, NIL)))))));
1009 }
1010
1011 int
list8(int x1,int x2,int x3,int x4,int x5,int x6,int x7,int x8)1012 list8(int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8)
1013 {
1014 return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
1015 cons(x6,
1016 cons(x7,
1017 cons(x8,
1018 NIL)))))))));
1019 }
1020
1021 int
list10(int x1,int x2,int x3,int x4,int x5,int x6,int x7,int x8,int x9,int x10)1022 list10(int x1, int x2, int x3, int x4, int x5,
1023 int x6, int x7, int x8, int x9, int x10)
1024 {
1025 return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
1026 cons(x6,
1027 cons(x7,
1028 cons(x8,
1029 cons
1030 (x9,
1031 cons
1032 (x10,
1033 NIL)))))))))));
1034 }
1035
1036
1037 int
list11(int x1,int x2,int x3,int x4,int x5,int x6,int x7,int x8,int x9,int x10,int x11)1038 list11(int x1, int x2, int x3, int x4, int x5,
1039 int x6, int x7, int x8, int x9, int x10, int x11)
1040 {
1041 return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
1042 cons(x6,
1043 cons(x7,
1044 cons(x8,
1045 cons
1046 (x9,
1047 cons
1048 (x10,
1049 cons
1050 (x11,
1051 NIL))))))))))));
1052 }
1053
1054
1055 int
reverse(int x)1056 reverse(int x)
1057 {
1058 int res;
1059
1060 res = NIL;
1061 while (!nullp(x) && !atomp(x)) {
1062 res = cons(car(x), res);
1063 x = cdr(x);
1064 }
1065 return (res);
1066 }
1067
1068 int
hreverse(int x)1069 hreverse(int x)
1070 {
1071 int res;
1072
1073 res = NIL;
1074 while (!nullp(x) && !atomp(x)) {
1075 res = hcons(car(x), res);
1076 x = cdr(x);
1077 }
1078 return (res);
1079 }
1080
1081 int
nreverse(int x)1082 nreverse(int x)
1083 {
1084 int res;
1085
1086 res = NIL;
1087 while (!nullp(x) && !atomp(x)) {
1088 int y;
1089
1090 y = cdr(x);
1091 SET_CDR(x, res);
1092 res = x;
1093 x = y;
1094 }
1095 return (res);
1096 }
1097
1098 int
last(int x)1099 last(int x)
1100 {
1101 return (car(reverse(x)));
1102 }
1103
1104 int
append(int x,int y)1105 append(int x, int y)
1106 {
1107 if (nullp(x))
1108 return (y);
1109 else
1110 return (cons(car(x), append(cdr(x), y)));
1111 }
1112
1113 int
happend(int x,int y)1114 happend(int x, int y)
1115 {
1116 if (nullp(x))
1117 return (y);
1118 else
1119 return (hcons(car(x), happend(cdr(x), y)));
1120 }
1121
1122
1123 int
nconc(int x,int y)1124 nconc(int x, int y)
1125 {
1126 int ls;
1127
1128 if (nullp(x))
1129 return (y);
1130
1131 ls = x;
1132 while (!nullp(cdr(ls))) {
1133 ls = cdr(ls);
1134 }
1135 SET_CDR(ls, y);
1136 return (x);
1137 }
1138
1139 int
create_list(int x,int y)1140 create_list(int x, int y)
1141 {
1142 if (x == 0)
1143 return (NIL);
1144 else
1145 return (cons(copy(y), create_list(x - 1, y)));
1146 }
1147
1148 int
copy(int x)1149 copy(int x)
1150 {
1151 if (nullp(x))
1152 return (NIL);
1153 else if (x == UNDEF)
1154 return (makedummy());
1155 else if (integerp(x))
1156 return (makeint(GET_INT(x)));
1157 else if (floatp(x))
1158 return (makeflt(GET_FLT(x)));
1159 else if (charp(x))
1160 return (makechar(GET_NAME(x)));
1161 else if (stringp(x))
1162 return (makestr(GET_NAME(x)));
1163 else if (listp(x))
1164 return (cons(copy(car(x)), copy(cdr(x))));
1165 else
1166 return (x);
1167 }
1168
1169
1170 int
listref(int lis,int n)1171 listref(int lis, int n)
1172 {
1173 while (!(nullp(lis))) {
1174 if (n == 0) {
1175 return (car(lis));
1176 } else {
1177 lis = cdr(lis);
1178 n--;
1179 }
1180 }
1181 return (NIL);
1182 }
1183
1184 int
listref1(int lis,int n)1185 listref1(int lis, int n)
1186 {
1187 while (!(nullp(lis))) {
1188 if (n == 0) {
1189 return (lis);
1190 } else {
1191 lis = cdr(lis);
1192 n--;
1193 }
1194 }
1195 return (NIL);
1196 }
1197
1198
1199 int
listcopy(int lis)1200 listcopy(int lis)
1201 {
1202 if (nullp(lis))
1203 return (NIL);
1204 else if (!listp(lis))
1205 return (lis);
1206 else
1207 return (cons(car(lis), listcopy(cdr(lis))));
1208 }
1209
1210 int
remove_list(int x,int y)1211 remove_list(int x, int y)
1212 {
1213
1214 if (nullp(x))
1215 return (NIL);
1216 else if (member(car(x), y))
1217 return (cdr(x));
1218 else
1219 return (cons(car(x), remove_list(cdr(x), y)));
1220 }
1221
1222 void
vector_set(int v,int n,int obj)1223 vector_set(int v, int n, int obj)
1224 {
1225 SET_VEC_ELT(v, n, obj);
1226 }
1227
1228 int
vector_ref(int v,int n)1229 vector_ref(int v, int n)
1230 {
1231 return (GET_VEC_ELT(v, n));
1232 }
1233
1234 int
vector_length(int v)1235 vector_length(int v)
1236 {
1237 return (GET_CDR(v));
1238 }
1239
1240 int
array_length(int obj)1241 array_length(int obj)
1242 {
1243 return (GET_CDR(obj));
1244 }
1245
1246
1247 // obj is array or vector
1248 // ls is index. e.g. (0 1 1)
1249 int
array_ref(int obj,int ls)1250 array_ref(int obj, int ls)
1251 {
1252 int size,
1253 index;
1254
1255 if (vectorp(obj)) {
1256 size = list1(vector_length(obj));
1257 } else {
1258 size = array_length(obj); // e.g. #3a(((0 1 2) (3 4 5))) ->
1259 // (1 2 3)
1260 }
1261
1262 index = 0;
1263 size = cdr(size);
1264 while (!nullp(ls)) {
1265 if (nullp(cdr(ls)))
1266 index = index + GET_INT(car(ls));
1267 else if (GET_INT(car(ls)) != 0)
1268 index = index + GET_INT(car(size)) * GET_INT(car(ls));
1269 /*
1270 * else if(GET_INT(car(ls)) == 0) index = index;
1271 */
1272
1273 size = cdr(size);
1274 ls = cdr(ls);
1275 }
1276 return (vector_ref(obj, index));
1277 }
1278
1279 int
array_set(int obj,int ls,int val)1280 array_set(int obj, int ls, int val)
1281 {
1282 int size,
1283 index;
1284
1285 if (vectorp(obj)) {
1286 size = list1(vector_length(obj));
1287 } else {
1288 size = array_length(obj); // e.g. #3a(((0 1 2) (3 4 5))) ->
1289 // (1 2 3)
1290 }
1291 index = 0;
1292 size = cdr(size);
1293 while (!nullp(ls)) {
1294 if (nullp(cdr(ls)))
1295 index = index + GET_INT(car(ls));
1296 else if (GET_INT(car(ls)) != 0)
1297 index = index + GET_INT(car(size)) * GET_INT(car(ls));
1298 /*
1299 * else if(GET_INT(car(ls)) == 0) index = index;
1300 */
1301
1302 size = cdr(size);
1303 ls = cdr(ls);
1304 }
1305 vector_set(obj, index, val);
1306 return (obj);
1307 }
1308
1309 // calculation of array's dimension
1310 // e.g. ((1 2)(3 4)(5 6)) -> (3 2)
1311 int
array_dim(int n,int ls)1312 array_dim(int n, int ls)
1313 {
1314 if (!nullp(ls) && atomp(ls) && n > 0)
1315 error(ILLEGAL_ARGS, "array", NIL);
1316 else if (n == 0)
1317 return (NIL);
1318 else
1319 return (cons(makeint(length(ls)), array_dim(n - 1, car(ls))));
1320
1321 return (UNDEF);
1322 }
1323
1324 // n=0 ex ((1 2) 3 (4 5)) -> (1 2 3 4 5)
1325 int
flatten(int n,int ls)1326 flatten(int n, int ls)
1327 {
1328 if (nullp(ls))
1329 return (ls);
1330 else if (n <= 1)
1331 return (ls);
1332 else if (atomp(car(ls)))
1333 return (cons(car(ls), flatten(n, cdr(ls))));
1334 else
1335 return (append(flatten(n - 1, car(ls)), flatten(n, cdr(ls))));
1336
1337 }
1338
1339
1340 // ex(1 2 3 4) -> ((1 2)(3 4))
1341 int
structured(int ls,int st)1342 structured(int ls, int st)
1343 {
1344 return (structured1(ls, reverse(st)));
1345 }
1346
1347 int
structured1(int ls,int st)1348 structured1(int ls, int st)
1349 {
1350 if (nullp(cdr(st)))
1351 return (ls);
1352 else
1353 return (structured1(structured2(ls, GET_INT(car(st))), cdr(st)));
1354 }
1355
1356 int
structured2(int ls,int n)1357 structured2(int ls, int n)
1358 {
1359 if (nullp(ls))
1360 return (NIL);
1361 else
1362 return (cons(list_take(ls, n), structured2(list_drop(ls, n), n)));
1363 }
1364
1365 int
list_take(int ls,int n)1366 list_take(int ls, int n)
1367 {
1368 if (n == 0)
1369 return (NIL);
1370 else
1371 return (cons(car(ls), list_take(cdr(ls), n - 1)));
1372 }
1373
1374 int
list_drop(int ls,int n)1375 list_drop(int ls, int n)
1376 {
1377 if (n == 0)
1378 return (ls);
1379 else
1380 return (list_drop(cdr(ls), n - 1));
1381
1382 }
1383
1384 // generate array from list. ex #na(ls) ls=((1 2)(3 4))
1385 int
array(int n,int ls)1386 array(int n, int ls)
1387 {
1388 int dim,
1389 res,
1390 ls1,
1391 i;
1392
1393 dim = array_dim(n, ls);
1394 if (n == 0) {
1395 res = makearray(dim, ls);
1396 return (res);
1397 } else if (n == 1)
1398 res = makevec(GET_INT(car(dim)), UNDEF);
1399 else
1400 res = makearray(dim, UNDEF);
1401
1402 ls1 = flatten(n, ls);
1403 i = 0;
1404 while (!nullp(ls1)) {
1405 SET_VEC_ELT(res, i, car(ls1));
1406 i++;
1407 ls1 = cdr(ls1);
1408 }
1409 SET_PROP(res, ls); // for FAST compiler regist original list
1410 return (res);
1411 }
1412
1413 int
vector_to_list(int x)1414 vector_to_list(int x)
1415 {
1416 int res,
1417 i;
1418
1419 i = vector_length(x) - 1;
1420 res = NIL;
1421 while (i >= 0) {
1422 res = cons(vector_ref(x, i), res);
1423 i--;
1424 }
1425 return (res);
1426 }
1427
1428 static inline void
SET_CHAR(int addr,char x)1429 SET_CHAR(int addr, char x)
1430 {
1431 REQUIRE(CELLRANGE(addr) && GET_TAG(addr) == CHR);
1432 heap[addr].name[0] = x;
1433 }
1434
1435 int
string_to_vector(int x)1436 string_to_vector(int x)
1437 {
1438 int res,
1439 len,
1440 i,
1441 ref;
1442 char c;
1443
1444 len = strlen(GET_NAME(x));
1445 res = makevec(len, UNDEF);
1446 ref = 0;
1447 i = 0;
1448 c = STRING_REF(x, i++);
1449 while (c != NUL) {
1450 int chr;
1451
1452 chr = makechar("?");
1453 SET_CHAR(chr, c);
1454 vector_set(res, ref++, chr);
1455 c = STRING_REF(x, i++);
1456 }
1457 return (res);
1458 }
1459
1460 int
string_to_list(int x)1461 string_to_list(int x)
1462 {
1463 int i,
1464 len,
1465 res;
1466
1467 res = NIL;
1468 len = strlen(GET_NAME(x));
1469 for (i = 0; i < len; i++) {
1470 int chr;
1471 char c;
1472
1473 chr = makechar("?");
1474 c = STRING_REF(x, i);
1475 SET_CHAR(chr, c);
1476 res = cons(chr, res);
1477 }
1478 return (reverse(res));
1479 }
1480
1481 int
substr(int x,int s,int e)1482 substr(int x, int s, int e)
1483 {
1484 int i,
1485 j;
1486 char *str;
1487
1488 str = ALLOC((e - s) + 1);
1489 j = 0;
1490 for (i = s; i < e; i++) {
1491 str[j] = STRING_REF(x, i);
1492 j++;
1493 }
1494 str[j] = NUL;
1495 int res = makestr(str);
1496 FREE(str);
1497 return res;
1498 }
1499
1500 int
string_length(int x)1501 string_length(int x)
1502 {
1503 return (strlen(GET_NAME(x)));
1504 }
1505
1506 int
string_ref(int x,int y)1507 string_ref(int x, int y)
1508 {
1509 char str[CHARSIZE];
1510
1511 str[0] = STRING_REF(x, GET_INT(y));
1512 str[1] = NUL;
1513 return (makechar(str));
1514 }
1515
1516 int
string_set(int x,int y,int z)1517 string_set(int x, int y, int z)
1518 {
1519
1520 STRING_SET(x, GET_INT(y), GET_CHAR(z));
1521 return (y);
1522 }
1523
1524 int
sublis(int x,int s,int e)1525 sublis(int x, int s, int e)
1526 {
1527 int i,
1528 res;
1529
1530 res = NIL;
1531 i = 0;
1532 while (!nullp(x)) {
1533 if (i >= s && i < e)
1534 res = cons(copy(car(x)), res);
1535 i++;
1536 x = cdr(x);
1537 }
1538 return (reverse(res));
1539 }
1540
1541 int
subvec(int x,int s,int e)1542 subvec(int x, int s, int e)
1543 {
1544 int i,
1545 j,
1546 res;
1547
1548 res = makevec(e - s, UNDEF);
1549 j = 0;
1550 for (i = s; i < e; i++) {
1551 SET_VEC_ELT(res, j, copy(GET_VEC_ELT(x, i)));
1552 j++;
1553 }
1554 return (res);
1555 }
1556
1557 // compare priority of argument list of method
1558 // if x is higher than y, return 1.
1559 int
high_priority_p(int x,int y)1560 high_priority_p(int x, int y)
1561 {
1562 int args1,
1563 args2,
1564 argx,
1565 argy,
1566 classx,
1567 classy;
1568
1569 if (GET_OPT(x) > GET_OPT(y)) // :around ... etc
1570 return (0);
1571 else if (GET_OPT(x) < GET_OPT(y))
1572 return (1);
1573 else if (GET_OPT(x) == AFTER && GET_OPT(y) == AFTER) {
1574 /*
1575 * case :after this is reverse case primary when compiling,
1576 * compiler chenge order. use (change-priority-for-compiler t)
1577 */
1578 args1 = car(GET_CAR(x)); // lambda-list
1579 args2 = car(GET_CAR(y));
1580 while (!nullp(args1)) {
1581 argx = car(args1);
1582 argy = car(args2);
1583 if (atomp(argy)) { // case of no class information
1584 args1 = cdr(args1);
1585 args2 = cdr(args2);
1586 } else {
1587 if (atomp(argx))
1588 return (1);
1589 classx = GET_AUX(cadr(argx));
1590 classy = GET_AUX(cadr(argy));
1591 if (subclassp(classy, classx))
1592 return (1);
1593
1594 args1 = cdr(args1);
1595 args2 = cdr(args2);
1596 }
1597
1598 }
1599 return (0);
1600 } else {
1601 args1 = car(GET_CAR(x)); // lambda-list
1602 args2 = car(GET_CAR(y));
1603 while (!nullp(args1)) {
1604 argx = car(args1);
1605 argy = car(args2);
1606 if (atomp(argx)) { // case of no class information
1607 args1 = cdr(args1);
1608 args2 = cdr(args2);
1609 } else {
1610 if (atomp(argy))
1611 return (1);
1612 classx = GET_AUX(cadr(argx));
1613 classy = GET_AUX(cadr(argy));
1614 if (subclassp(classx, classy))
1615 return (1);
1616
1617 args1 = cdr(args1);
1618 args2 = cdr(args2);
1619 }
1620
1621 }
1622 return (0);
1623 }
1624 }
1625
1626 void
insert_method(int x,int func)1627 insert_method(int x, int func)
1628 {
1629 int methods,
1630 res;
1631
1632 methods = GET_CDR(func);
1633 if (nullp(methods)) {
1634 SET_CDR(func, hlist1(x));
1635 return;
1636 }
1637 res = NIL;
1638 while (!nullp(methods)) {
1639 if (high_priority_p(car(methods), x)) {
1640 res = hcons(car(methods), res);
1641 methods = cdr(methods);
1642 } else
1643 break;
1644 }
1645 res = happend(hreverse(hcons(x, res)), methods);
1646 SET_CDR(func, res);
1647 return;
1648 }
1649
1650 void
resort_method(int func)1651 resort_method(int func)
1652 {
1653 int methods,
1654 res;
1655
1656 methods = GET_CDR(func);
1657 if (nullp(methods))
1658 return;
1659
1660 res = hcons(car(methods), NIL);
1661 methods = cdr(methods);
1662 while (!nullp(methods)) {
1663 int temp,
1664 x;
1665
1666 x = car(methods);
1667 temp = NIL;
1668 bool high_priority_found = false;
1669 while (!nullp(res)) {
1670 if (high_priority_p(x, car(res))) {
1671 res = happend(hreverse(temp), hcons(x, res));
1672 high_priority_found = true;
1673 break;
1674 } else {
1675 temp = hcons(car(res), temp);
1676 res = cdr(res);
1677 }
1678 }
1679 if (!high_priority_found) {
1680 res = hreverse(cons(x, temp));
1681 }
1682 methods = cdr(methods);
1683 }
1684 SET_CDR(func, res);
1685 }
1686
1687 void
redef_generic(void)1688 redef_generic(void)
1689 {
1690 int ls;
1691
1692 ls = generic_list;
1693 while (!nullp(ls)) {
1694 resort_method(GET_CAR(car(ls)));
1695 ls = cdr(ls);
1696 }
1697 redef_flag = false;
1698 return;
1699 }
1700
1701 int
method_qualifier_p(int x)1702 method_qualifier_p(int x)
1703 {
1704 if (eqp(x, makesym(":BEFORE")) ||
1705 eqp(x, makesym(":AFTER")) || eqp(x, makesym(":AROUND")))
1706 return (1);
1707 else
1708 return (0);
1709 }
1710
1711 // ------------for copy GC-----------------
1712 int
copy_work(int x)1713 copy_work(int x)
1714 {
1715 if (x < WORK1) // nil t ...
1716 return (x);
1717
1718 switch (GET_TAG(x)) {
1719 case INTN:
1720 return (copy_int(x));
1721 case FLTN:
1722 return (copy_flt(x));
1723 case LONGN:
1724 return (copy_long(x));
1725 case BIGX:
1726 return (copy_bignum(x));
1727 case VEC:
1728 return (copy_vec(x));
1729 case ARR:
1730 return (copy_array(x));
1731 case STR:
1732 return (copy_str(x));
1733 case CHR:
1734 return (copy_char(x));
1735 case SYM:
1736 return (x);
1737 case SUBR:
1738 return (x);
1739 case FSUBR:
1740 return (x);
1741 case FUNC:
1742 return (copy_func(x));
1743 case MACRO:
1744 return (copy_macro(x));
1745 case CLASS:
1746 return (copy_class(x));
1747 case STREAM:
1748 return (copy_stream(x));
1749 case GENERIC:
1750 return (copy_generic(x));
1751 case METHOD:
1752 return (x); // ****
1753 case INSTANCE:
1754 return (x); // ****
1755 case LIS:
1756 return (cons(copy_work(car(x)), copy_work(cdr(x))));
1757 case DUMMY:
1758 return (x);
1759 default:
1760 Fmt_print("error addr=%d ", x);
1761 return (x);
1762 }
1763
1764 return (x);
1765 }
1766
1767
1768 int
copy_heap(int x)1769 copy_heap(int x)
1770 {
1771 int save,
1772 res;
1773
1774 save = gc_sw;
1775 gc_sw = 0;
1776 res = copy_work(x);
1777 gc_sw = save;
1778 return (res);
1779 }
1780
1781 int
copy_symbol(int x)1782 copy_symbol(int x)
1783 {
1784
1785 SET_CAR(x, copy_work(GET_CAR(x)));
1786 SET_CDR(x, copy_work(GET_CDR(x)));
1787 SET_OPT(x, GET_OPT(x));
1788 return (x);
1789 }
1790
1791 /*
1792 * copy_??? for copying GC
1793 */
1794 int
copy_int(int x)1795 copy_int(int x)
1796 {
1797 // int addr = NIL;
1798
1799 // addr = freshcell();
1800 // SET_TAG(addr,INTN);
1801 // SET_INT(addr,GET_INT(x));
1802 // SET_AUX(addr,cfixnum); //class fixnum
1803 return (x);
1804 }
1805
1806 int
copy_long(int x)1807 copy_long(int x)
1808 {
1809 int addr = NIL;
1810
1811 addr = freshcell();
1812 SET_TAG(addr, LONGN);
1813 SET_LONG(addr, GET_LONG(x));
1814 SET_AUX(addr, clongnum); // class longnum
1815 return (addr);
1816 }
1817
1818
1819 int
copy_flt(int x)1820 copy_flt(int x)
1821 {
1822 int addr = NIL;
1823
1824 addr = freshcell();
1825 SET_TAG(addr, FLTN);
1826 SET_FLT(addr, GET_FLT(x));
1827 SET_AUX(addr, cfloat); // class float
1828 return (addr);
1829 }
1830
1831 static inline int *
GET_VEC(int addr)1832 GET_VEC(int addr)
1833 {
1834 return heap[addr].val.car.dyna_vec;
1835 }
1836
1837 int
copy_vec(int x)1838 copy_vec(int x)
1839 {
1840 int addr = NIL;
1841
1842 addr = freshcell();
1843 SET_VEC(addr, GET_VEC(x)); // vector elements
1844 SET_TAG(addr, VEC);
1845 SET_CDR(addr, GET_CDR(x)); // vector size
1846 SET_AUX(addr, cgeneral_vector); // class general-vector
1847 return (addr);
1848 }
1849
1850
1851 int
copy_array(int x)1852 copy_array(int x)
1853 {
1854 int addr = NIL;
1855
1856 addr = freshcell();
1857 SET_VEC(addr, GET_VEC(x)); // array or vector
1858 SET_TAG(addr, GET_TAG(x)); // tag ARR or VEC
1859 SET_CDR(addr, GET_CDR(x)); // dimension
1860 SET_AUX(addr, GET_AUX(x)); // class
1861 return (addr);
1862 }
1863
1864
1865 int
copy_str(int x)1866 copy_str(int x)
1867 {
1868 int addr = NIL;
1869
1870 addr = freshcell();
1871 SET_TAG(addr, STR); // tag
1872 heap[addr].name = heap[x].name; // string
1873 SET_AUX(addr, GET_AUX(x)); // class string
1874 return (addr);
1875 }
1876
1877
1878 int
copy_char(int x)1879 copy_char(int x)
1880 {
1881 int addr = NIL;
1882
1883 addr = freshcell();
1884 SET_TAG(addr, CHR);
1885 heap[addr].name = heap[x].name;
1886 SET_AUX(addr, GET_AUX(x));
1887 return (addr);
1888 }
1889
1890 int
copy_func(int x)1891 copy_func(int x)
1892 {
1893 int val;
1894
1895 val = freshcell();
1896 SET_TAG(val, FUNC);
1897 SET_NAME(val, GET_NAME(x));
1898 SET_CAR(val, copy_work(GET_CAR(x)));
1899 SET_CDR(val, copy_work(GET_CDR(x)));
1900 SET_AUX(val, GET_AUX(x)); // class function
1901 SET_OPT(val, GET_OPT(x)); // amount of argument
1902 return (val);
1903 }
1904
1905 int
copy_generic(int x)1906 copy_generic(int x)
1907 {
1908 int val;
1909
1910 val = freshcell();
1911 SET_TAG(val, GENERIC);
1912 SET_NAME(val, GET_NAME(x));
1913 SET_CAR(val, GET_CAR(x));
1914 SET_OPT(val, GET_OPT(x)); // amount of argument
1915 SET_CDR(val, copy_work(GET_CDR(x))); // method
1916 SET_AUX(val, GET_AUX(x));
1917 return (val);
1918 }
1919
1920 int
copy_macro(int x)1921 copy_macro(int x)
1922 {
1923 int val;
1924
1925 val = freshcell();
1926 SET_TAG(val, MACRO);
1927 SET_CAR(val, copy_work(GET_CAR(x)));
1928 return (val);
1929 }
1930
1931 int
copy_stream(int x)1932 copy_stream(int x)
1933 {
1934 int addr;
1935
1936 addr = freshcell();
1937 SET_TAG(addr, STREAM);
1938 SET_PORT(addr, GET_PORT(x));
1939 SET_CDR(addr, GET_CDR(x)); // string-stream-position
1940 SET_AUX(addr, GET_AUX(x)); // class
1941 SET_OPT(addr, GET_OPT(x)); // input/output/inout
1942 return (addr);
1943 }
1944
1945 int
copy_class(int x)1946 copy_class(int x)
1947 {
1948 int addr;
1949
1950 addr = freshcell();
1951 SET_TAG(addr, CLASS);
1952 SET_NAME(addr, GET_NAME(x));
1953 SET_CAR(addr, GET_CAR(x));
1954 SET_CDR(addr, GET_CAR(x));
1955 SET_AUX(addr, GET_CAR(x));
1956 return (addr);
1957 }
1958
1959
1960 int
copy_bignum(int x)1961 copy_bignum(int x)
1962 {
1963 int addr,
1964 msb,
1965 sign;
1966
1967 sign = get_sign(x);
1968 addr = msb = copy_gen_big();
1969 while (!nullp(next(x))) {
1970 msb = copy_cons_next(GET_CAR(x), msb);
1971 x = next(x);
1972 }
1973 SET_TAG(addr, BIGX);
1974 set_sign(addr, sign);
1975 SET_AUX(addr, cbignum);
1976 return (addr);
1977 }
1978
1979 /*
1980 * x=new y=link if it is first cell, store the cell, else chain a new
1981 * cell.
1982 */
1983 int
copy_cons_next(int x,int y)1984 copy_cons_next(int x, int y)
1985 {
1986 int addr = NIL;
1987
1988 if (GET_PROP(y) == -1) {
1989 SET_PROP(y, NIL);
1990 SET_CAR(y, x);
1991 addr = y;
1992 } else {
1993 addr = freshcell();
1994 SET_CAR(addr, x);
1995 SET_CDR(y, addr);
1996 SET_PROP(addr, y);
1997 SET_CDR(addr, NIL);
1998 }
1999 return (addr);
2000 }
2001
2002
2003 /*
2004 * To check first cell, prop=-1. therefor when compute bignum, if it is
2005 * first cell, store data the cell. or else chain cell with cons_next.
2006 *
2007 */
2008 int
copy_gen_big(void)2009 copy_gen_big(void)
2010 {
2011 int addr = NIL;
2012
2013 addr = freshcell();
2014 SET_CDR(addr, NIL);
2015 SET_PROP(addr, -1); // mark of first cell
2016 return (addr);
2017 }
2018
2019
2020 /*
2021 * copy symbol of hash list
2022 */
2023
2024 void
copy_hash(int x)2025 copy_hash(int x)
2026 {
2027
2028 if (nullp(x))
2029 return;
2030 else {
2031 SET_CAR(x, copy_symbol(car(x)));
2032 copy_hash(cdr(x));
2033 }
2034 }
2035