1 /*
2 * memo lisp-2 symbol-address car=function-addr, cdr=global-val closure
3 * function-address car=arg+body, cdr=environment
4 */
5
6
7 #include <stdio.h>
8 #include <string.h>
9 #include <ctype.h>
10 #include <stdlib.h>
11 #include <math.h>
12 #include <stdint.h>
13 #include "eisl.h"
14 #include "nana.h"
15 #include "mem.h"
16 #include "fmt.h"
17 #include "except.h"
18 #include "str.h"
19
20 void
initcell(void)21 initcell(void)
22 {
23 int addr,
24 x;
25
26 // initialize heap area
27 for (addr = 0; addr < CELLSIZE; addr++) {
28 /*
29 * heap[addr].flag = FRE; FRE == 0
30 */
31 heap[addr].val.cdr.intnum = addr + 1;
32 /*
33 * heap[addr].aux = 0; heap[addr].option = 0;
34 */
35 }
36 hp = 0;
37 fc = CELLSIZE;
38
39 for (x = 0; x < HASHTBSIZE; x++)
40 cell_hash_table[x] = NIL;
41
42
43 // 0th address is for NIL, set initial environment
44 makesym("NIL"); // 0th address NIL
45 SET_AUX(NIL, CLASS_NULL); // class of nil is null
46 SET_OPT(NIL, CONSTN);
47 makesym("T"); // 2nd address is T
48 SET_AUX(T, CLASS_SYMBOL); // class of t is symbol
49 SET_OPT(T, CONSTN);
50 makesym("<undef>"); // 4th address is UNDEF
51 SET_AUX(UNDEF, CLASS_SYMBOL); // class of <undef> is symbol
52 makesym("<file-end>"); // 6the address is FEND
53 SET_AUX(FEND, CLASS_SYMBOL); // class of <end-of-file> is
54 // symbol
55 ep = 0;
56 dp = 0;
57 sp = 0;
58 ap = 0;
59 }
60
61 void
bindclass(const char * name,int cl)62 bindclass(const char *name, int cl)
63 {
64 int sym;
65
66 sym = makesym(name);
67 SET_AUX(sym, cl);
68 SET_OPT(cl, SYSTEM); // built-in-class
69 SET_OPT(sym, SYSTEM); // symbol formated by <***> are
70 // built-in-classes
71 }
72
73 // class aux = ((format-string . error-msg)(format-arguments . args))
74 void
initerrargs(int cl)75 initerrargs(int cl)
76 {
77 int vars,
78 args;
79
80 vars = list11(cons(makesym("a"), UNDEF), // format-string
81 cons(makesym("b"), UNDEF), // format-arguments
82 cons(makesym("c"), UNDEF), // function
83 cons(makesym("d"), UNDEF), // operation
84 cons(makesym("e"), UNDEF), // operands
85 cons(makesym("f"), UNDEF), // object
86 cons(makesym("g"), UNDEF), // expected-class
87 cons(makesym("h"), UNDEF), // string
88 cons(makesym("i"), UNDEF), // stream
89 cons(makesym("j"), UNDEF), // name
90 cons(makesym("k"), UNDEF)); // namespace
91
92 SET_CDR(cl, vars);
93 args = list11(cons(makesym("format-string"), makesym("a")),
94 cons(makesym("format-arguments"), makesym("b")),
95 cons(makesym("function"), makesym("c")),
96 cons(makesym("operation"), makesym("d")),
97 cons(makesym("operands"), makesym("e")),
98 cons(makesym("object"), makesym("f")),
99 cons(makesym("expected-class"), makesym("g")),
100 cons(makesym("string"), makesym("h")),
101 cons(makesym("stream"), makesym("i")),
102 cons(makesym("name"), makesym("j")),
103 cons(makesym("namespace"), makesym("k")));
104 SET_AUX(cl, args);
105
106 }
107
108 void
initclass(void)109 initclass(void)
110 {
111 cobject = makeclass("object", NIL);
112 cbasic_array = makeclass("basic-array", cobject);
113 cbasic_array_star = makeclass("basic-array*", cbasic_array);
114 cgeneral_array_star = makeclass("general-array*", cbasic_array_star);
115 cbasic_vector = makeclass("basic-vector", cbasic_array);
116 cgeneral_vector = makeclass("general-vector", cbasic_vector);
117 cstring = makeclass("string", cbasic_vector);
118 cbuilt_in_class = makeclass("built-in-class", cbuilt_in_class);
119 ccharacter = makeclass("character", cobject);
120 cfunction = makeclass("function", cobject);
121 cgeneric_function = makeclass("generic-function", cfunction);
122 cstandard_generic_function =
123 makeclass("standard-generic-function", cgeneric_function);
124 clist = makeclass("list", cobject);
125 ccons = makeclass("cons", clist);
126 cnull =
127 makeclass("null", list2(makesym("<SYMBOL>"), makesym("<LIST>")));
128 csymbol = makeclass("symbol", cobject);
129 cnumber = makeclass("number", cobject);
130 cfloat = makeclass("float", cnumber);
131 cinteger = makeclass("integer", cnumber);
132 cserious_condition = makeclass("serious-condition", cobject);
133 cerror = makeclass("error", cserious_condition);
134 carithmetic_error = makeclass("arithmetic-condition", cerror);
135 cdivision_by_zero = makeclass("division-by-zero", carithmetic_error);
136 cfloating_point_overflow =
137 makeclass("floating-point-overflow", carithmetic_error);
138 cfloating_point_underflow =
139 makeclass("floating-point-underflow", carithmetic_error);
140 ccontrol_error = makeclass("control-error", cerror);
141 cparse_error = makeclass("parse-error", cerror);
142 cprogram_error = makeclass("program-error", cerror);
143 cdomain_error = makeclass("domain-error", cprogram_error);
144 cclass_error = makeclass("class-error", cprogram_error);
145 cundefined_entity = makeclass("undefined-entity", cprogram_error);
146 cunbound_variable = makeclass("unbound-variable", cundefined_entity);
147 cundefined_function =
148 makeclass("undefined-function", cundefined_entity);
149 csimple_error = makeclass("simple-error", cerror);
150 cstream_error = makeclass("stream-error", cerror);
151 cend_of_stream = makeclass("end-of-stream", cstream_error);
152 cstorage_exhausted =
153 makeclass("storage-exhausted", cserious_condition);
154
155 cstandard_class = makeclass("standard-class", cobject);
156 cstandard_object = makeclass("standard-object", cobject);
157 cstream = makeclass("stream", cobject);
158 cinvalid = makeclass("invalid", cinvalid);
159 cfixnum = makeclass("fixnum", cinteger);
160 clongnum = makeclass("longnum", cinteger);
161 cbignum = makeclass("bignum", cinteger);
162
163 bindclass("<OBJECT>", cobject);
164 bindclass("<BASIC-ARRAY>", cbasic_array);
165 bindclass("<GENERAL-ARRAY*>", cgeneral_array_star);
166 bindclass("<BASIC-ARRAY*>", cbasic_array_star);
167 bindclass("<BASIC-VECTOR>", cbasic_vector);
168 bindclass("<GENERAL-VECTOR>", cgeneral_vector);
169 bindclass("<STRING>", cstring);
170 bindclass("<BUILT-IN-CLASS>", cbuilt_in_class);
171 bindclass("<CHARACTER>", ccharacter);
172 bindclass("<FUNCTION>", cfunction);
173 bindclass("<GENERIC-FUNCTION>", cgeneric_function);
174 bindclass("<STANDARD-GENERIC-FUNCTION>", cstandard_generic_function);
175 bindclass("<LIST>", clist);
176 bindclass("<CONS>", ccons);
177 bindclass("<NULL>", cnull);
178 bindclass("<SYMBOL>", csymbol);
179 bindclass("<NUMBER>", cnumber);
180 bindclass("<FLOAT>", cfloat);
181 bindclass("<INTEGER>", cinteger);
182 bindclass("<SERIOUS-CONDITION>", cserious_condition);
183 bindclass("<ERROR>", cerror);
184 bindclass("<ARITHMETIC-ERROR>", carithmetic_error);
185 bindclass("<DIVISION-BY-ZERO>", cdivision_by_zero);
186 bindclass("<FLOATING-POINT-OVERFLOW>", cfloating_point_overflow);
187 bindclass("<FLOATING-POINT-UNDERFLOW>", cfloating_point_underflow);
188 bindclass("<CONTROL-ERROR>", ccontrol_error);
189 bindclass("<PARSE-ERROR>", cparse_error);
190 bindclass("<PROGRAM-ERROR>", cprogram_error);
191 bindclass("<DOMAIN-ERROR>", cdomain_error);
192 bindclass("<CLASS-ERROR>", cclass_error);
193 bindclass("<UNDEFINED-ENTITY>", cundefined_entity);
194 bindclass("<UNBOUND-VARIABLE>", cunbound_variable);
195 bindclass("<UNDEFINED-FUNCTION>", cundefined_function);
196 bindclass("<SIMPLE-ERROR>", csimple_error);
197 bindclass("<STREAM-ERROR>", cstream_error);
198 bindclass("<END-OF-STREAM>", cend_of_stream);
199 bindclass("<STORAGE-EXHAUSTED>", cstorage_exhausted);
200 bindclass("<STANDARD-CLASS>", cstandard_class);
201 bindclass("<STANDARD-OBJECT>", cstandard_object);
202 bindclass("<STREAM>", cstream);
203 bindclass("<INVALID>", cinvalid);
204 bindclass("<FIXNUM>", cfixnum);
205 bindclass("<LONGNUM>", clongnum);
206 bindclass("<BIGNUM>", cbignum);
207
208 initerrargs(cserious_condition);
209 initerrargs(cerror);
210 initerrargs(carithmetic_error);
211 initerrargs(cdivision_by_zero);
212 initerrargs(cfloating_point_overflow);
213 initerrargs(cfloating_point_underflow);
214 initerrargs(ccontrol_error);
215 initerrargs(cparse_error);
216 initerrargs(cprogram_error);
217 initerrargs(cdomain_error);
218 initerrargs(cclass_error);
219 initerrargs(cundefined_entity);
220 initerrargs(cunbound_variable);
221 initerrargs(cundefined_function);
222 initerrargs(csimple_error);
223 initerrargs(cstream_error);
224 initerrargs(cend_of_stream);
225 initerrargs(cstorage_exhausted);
226
227 ENSURE(cnull == CLASS_NULL && csymbol == CLASS_SYMBOL);
228 }
229
230 void
initstream(void)231 initstream(void)
232 {
233 standard_input = makestream(stdin, EISL_INPUT, "standard-input");
234 standard_output = makestream(stdout, EISL_OUTPUT, "standard-output");
235 standard_error = makestream(stderr, EISL_OUTPUT, "error-output");
236 }
237
238 int
freshcell(void)239 freshcell(void)
240 {
241 int res;
242
243 if (gc_sw == 0) {
244 res = hp;
245 hp = GET_CDR(hp);
246 SET_CDR(res, 0);
247 fc--;
248 if (fc <= 50 && !handling_resource_err) {
249 handling_resource_err = true;
250 error(RESOURCE_ERR, "M&S freshcell", NIL);
251 }
252 return (res);
253 } else {
254 res = wp;
255 if (IS_VECTOR(res) || IS_ARRAY(res)) {
256 FREE(heap[res].val.car.dyna_vec);
257 } else if (IS_STRING(res)) {
258 FREE(heap[res].name);
259 }
260 SET_TAG(res, EMP);
261 SET_CAR(res, 0);
262 SET_CDR(res, 0);
263 SET_AUX(res, 0);
264 SET_PROP(res, 0);
265 SET_OPT(res, 0);
266 SET_TR(res, 0);
267 wp++;
268 if (wp < CELLSIZE && wp > CELLSIZE - 50 && !handling_resource_err) {
269 handling_resource_err = true;
270 error(RESOURCE_ERR, "copying freshcell", NIL);
271 } else if (wp > CELLSIZE && wp > CELLSIZE - 50
272 && !handling_resource_err) {
273 handling_resource_err = true;
274 error(RESOURCE_ERR, "copying freshcell", NIL);
275 }
276 return (res);
277 }
278 }
279
280
281 int
hfreshcell(void)282 hfreshcell(void)
283 {
284 int res;
285
286 res = hp;
287 hp = heap[hp].val.cdr.intnum;
288 SET_CDR(res, 0);
289 fc--;
290 if (fc <= 50 && !handling_resource_err) {
291 handling_resource_err = true;
292 error(RESOURCE_ERR, "hfreshcell", NIL);
293 }
294 return (res);
295 }
296
297 // set value to environment by destructive
298 // by deep-bind
299 void
setlexenv(int sym,int val)300 setlexenv(int sym, int val)
301 {
302 int addr;
303
304 addr = assq(sym, ep);
305 if (addr == FAILSE)
306 addlexenv(sym, val);
307 else
308 SET_CDR(addr, val);
309 }
310
311 // bind value to dynamic environment
312 int
setdynenv(int sym,int val)313 setdynenv(int sym, int val)
314 {
315 int i;
316
317 for (i = dp; i > 0; i--) {
318 if (dynamic[i][0] == sym) {
319 dynamic[i][1] = val;
320 return (T);
321 }
322 }
323 dp++;
324 if (dp >= DYNSIZE)
325 error(DYNAMIC_OVERF, "setdynenv", NIL);
326 dynamic[dp][0] = sym;
327 dynamic[dp][1] = val;
328 return (T);
329 }
330
331
332 // additinal of lexical variable
333 void
addlexenv(int sym,int val)334 addlexenv(int sym, int val)
335 {
336 ep = cons(cons(sym, val), ep);
337 }
338
339 // addition of dynamic variable
340 int
adddynenv(int sym,int val)341 adddynenv(int sym, int val)
342 {
343 dp++;
344 if (dp >= DYNSIZE)
345 error(DYNAMIC_OVERF, "adddynenv", NIL);
346 dynamic[dp][0] = sym;
347 dynamic[dp][1] = val;
348 return (T);
349 }
350
351
352 // environment is association list
353 // env = ((sym1 . val1) (sym2 . val2) ...)
354 // find value with assq
355 // when not find return FAILSE
356 int
findenv(int sym)357 findenv(int sym)
358 {
359 int addr;
360
361 addr = assq(sym, ep);
362
363 if (addr == FAILSE)
364 return (FAILSE);
365 else
366 return (cdr(addr));
367 }
368
369 // find in dynamic environment
370 int
finddyn(int sym)371 finddyn(int sym)
372 {
373 int i;
374
375 for (i = dp; i > 0; i--) {
376 if (dynamic[i][0] == sym)
377 return (dynamic[i][1]);
378 }
379 return (FAILSE);
380 }
381
382 // bind to association list destructively
383 void
setval(int sym,int val,int ls)384 setval(int sym, int val, int ls)
385 {
386 int addr;
387
388 addr = assq(sym, ls);
389 if (addr != FAILSE)
390 SET_CDR(addr, val);
391 }
392
393
394 // for uniqueness of symbol
395 int
getsym(const char * name,int index)396 getsym(const char *name, int index)
397 {
398 int addr;
399
400 addr = cell_hash_table[index];
401
402 while (addr != NIL) {
403 if (strcmp(name, GET_NAME(car(addr))) == 0)
404 return (car(addr));
405 else
406 addr = cdr(addr);
407 }
408 return (-1);
409 }
410
411 /*
412 * link list is generated in hheap area allways
413 */
414 int
addsym(const char * name,int index)415 addsym(const char *name, int index)
416 {
417 int addr,
418 res;
419
420 addr = cell_hash_table[index];
421 addr = hcons(res = makesym1(name), addr);
422 cell_hash_table[index] = addr;
423 return (res);
424 }
425
426 /*
427 * symbol car = function addr cdr = global value aux = class symbol option
428 * = CONSTN(constant )
429 */
430 int
makesym1(const char * pname)431 makesym1(const char *pname)
432 {
433 int addr;
434
435 addr = hfreshcell();
436 SET_TAG(addr, SYM);
437 TRY heap[addr].name = Str_dup(pname, 1, 0, 1);
438 EXCEPT(Mem_Failed)
439 error(MALLOC_OVERF, "makesym", NIL);
440 END_TRY;
441 SET_CAR(addr, NIL);
442 SET_CDR(addr, NIL);
443 SET_AUX(addr, csymbol); // class symbol
444 return (addr);
445 }
446
447 // calculate hash number
448 // modulo sum of each charactor's ASCII code with
449 // HASHTBSIZE(107)
450 int
hash(const char * name)451 hash(const char *name)
452 {
453 int res;
454
455 res = 0;
456 while (*name != NUL) {
457 res = res + (int) *name;
458 name++;
459 }
460 return (res % HASHTBSIZE);
461 }
462
463 // -------for debug------------------
DEF_GETTER(flag,FLAG,flag,NIL)464 DEF_GETTER(flag, FLAG, flag, NIL)
465 void cellprint(int addr)
466 {
467 switch (GET_FLAG(addr)) {
468 case FRE:
469 fputs("FRE ", stdout);
470 break;
471 case USE:
472 fputs("USE ", stdout);
473 break;
474 }
475 switch (GET_TAG(addr)) {
476 case EMP:
477 puts("EMP");
478 break;
479 case INTN:
480 Fmt_print("INTN %d\n", GET_INT(addr));
481 break;
482 case FLTN:
483 Fmt_print("FLTN %f\n", GET_FLT(addr));
484 break;
485 case LONGN:
486 Fmt_print("LONGN %D\n", GET_LONG(addr));
487 break;
488 case BIGX:
489 Fmt_print("BIGX %d\n", GET_CAR(addr));
490 break;
491 case SYM:
492 Fmt_print("SYM %07d %07d %07d %s\n", GET_CAR(addr),
493 GET_CDR(addr), GET_AUX(addr), GET_NAME(addr));
494 break;
495 case STR:
496 Fmt_print("STR %07d %07d %07d %s\n", GET_CAR(addr),
497 GET_CDR(addr), GET_AUX(addr), GET_NAME(addr));
498 break;
499 case LIS:
500 Fmt_print("LIS %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
501 GET_AUX(addr));
502 break;
503 case SUBR:
504 Fmt_print("SUBR %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
505 GET_AUX(addr));
506 break;
507 case FSUBR:
508 Fmt_print("FSUBR %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
509 GET_AUX(addr));
510 break;
511 case FUNC:
512 Fmt_print("FUNC %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
513 GET_AUX(addr));
514 break;
515 case MACRO:
516 Fmt_print("MACRO %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
517 GET_AUX(addr));
518 break;
519 case CLASS:
520 Fmt_print("CLASS %07d %07d %07d %s\n", GET_CAR(addr),
521 GET_CDR(addr), GET_AUX(addr), GET_NAME(addr));
522 break;
523 case GENERIC:
524 Fmt_print("GENE %07d %07d %07d\n", GET_CAR(addr), GET_CDR(addr),
525 GET_AUX(addr));
526 break;
527 default:
528 Fmt_print("cellprint(%d) tag switch default action\n", addr);
529 }
530 }
531
532 // heap dump
533 void
heapdump(int start,int end)534 heapdump(int start, int end)
535 {
536 int i;
537
538 puts("addr F TAG CAR CDR AUX NAME");
539 for (i = start; i <= end; i++) {
540 Fmt_print("%07d ", i);
541 cellprint(i);
542 }
543 }
544
545
546 void
store_backtrace(int x)547 store_backtrace(int x)
548 {
549 int i;
550
551 for (i = 1; i < BACKSIZE; i++) {
552 int y;
553
554 y = backtrace[i];
555 backtrace[i - 1] = y;
556 }
557 backtrace[BACKSIZE - 1] = x;
558 }
559
560 // ----------------------------------------
561
562 int
makeint(int intn)563 makeint(int intn)
564 {
565 // int addr;
566
567 // addr = freshcell();
568 // SET_TAG(addr,INTN);
569 // SET_INT(addr,intn);
570 // SET_AUX(addr,cfixnum); //class fixnum
571 if (intn >= 0)
572 return (INT_FLAG | intn);
573 else
574 return (intn);
575 }
576
577 int
makelong(long long int lngnum)578 makelong(long long int lngnum)
579 {
580 int addr;
581
582 addr = freshcell();
583 SET_TAG(addr, LONGN);
584 SET_LONG(addr, lngnum);
585 SET_AUX(addr, clongnum); // class longnum
586 return (addr);
587 }
588
589 int
makeflt(double floatn)590 makeflt(double floatn)
591 {
592 int addr;
593
594 addr = freshcell();
595 SET_TAG(addr, FLTN);
596 SET_FLT(addr, floatn);
597 SET_AUX(addr, cfloat); // class float
598 return (addr);
599 }
600
601 /*
602 * symbol car = function cdr = global value aux = class
603 */
604 int
makesym(const char * pname)605 makesym(const char *pname)
606 {
607 int index,
608 res;
609
610 index = hash(pname);
611 if ((res = getsym(pname, index)) != -1)
612 return (res);
613 else
614 return (addsym(pname, index));
615 }
616
617 /*
618 * function car = args&body cdr = environment aux = null func object is
619 * generated in heap area.
620 */
621 int
makefunc(const char * pname,int addr)622 makefunc(const char *pname, int addr)
623 {
624 int val;
625
626 val = hfreshcell();
627 SET_TAG(val, FUNC);
628 TRY heap[val].name = Str_dup(pname, 1, 0, 1);
629 EXCEPT(Mem_Failed)
630 error(MALLOC_OVERF, "makefunc", NIL);
631 END_TRY;
632 SET_CAR(val, copy_heap(addr));
633 SET_CDR(val, ep); // local environment
634 SET_AUX(val, cfunction); // class function
635 // if lambda is generated in method, save the method and given
636 // argument
637 if (generic_func != NIL)
638 SET_PROP(val, cons(next_method, generic_vars)); // method
639 //
640 // of
641 // generic-function
642 // and
643 // argument
644 //
645 SET_OPT(val, count_args(car(addr))); // amount of argument
646 return (val);
647 }
648
649 // amount of argument. if it has :rest or &rest, it is minus number
650 int
count_args(int ls)651 count_args(int ls)
652 {
653 int ls1,
654 n,
655 res;
656
657 ls1 = reverse(ls);
658 n = length(ls);
659 if (eqp(cadr(ls1), makesym(":REST")))
660 res = -1 * n;
661 else if (eqp(cadr(ls1), makesym("&REST")))
662 res = -1 * n;
663 else
664 res = n;
665
666 return (res);
667 }
668
669 int
makevec(int n,int obj)670 makevec(int n, int obj)
671 {
672 int res,
673 i,
674 *vec;
675
676 res = freshcell();
677 TRY vec = (int *) ALLOC(sizeof(int) * n);
678 EXCEPT(Mem_Failed)
679 error(MALLOC_OVERF, "make_vector", NIL);
680 END_TRY;
681 SET_TAG(res, VEC);
682 SET_VEC(res, vec);
683 for (i = 0; i < n; i++)
684 SET_VEC_ELT(res, i, copy(obj));
685 SET_CDR(res, n);
686 SET_AUX(res, cgeneral_vector); // class general-vector
687 return (res);
688 }
689
690
691
692 int
vector(int lis)693 vector(int lis)
694 {
695 int len,
696 i,
697 res;
698
699 len = length(lis);
700 i = 0;
701 res = makevec(len, UNDEF);
702 while (!nullp(lis)) {
703 vector_set(res, i, car(lis));
704 i++;
705 lis = cdr(lis);
706 }
707
708 return (res);
709 }
710
711 /*
712 * generic car = args cdr = method aux = class
713 */
714 int
makegeneric(char * pname,int lamlist,int body)715 makegeneric(char *pname, int lamlist, int body)
716 {
717 int val;
718
719 val = hfreshcell();
720 SET_TAG(val, GENERIC);
721 TRY heap[val].name = Str_dup(pname, 1, 0, 1);
722 EXCEPT(Mem_Failed)
723 error(MALLOC_OVERF, "makegeneric", NIL);
724 END_TRY;
725 SET_CAR(val, copy_heap(lamlist));
726 SET_OPT(val, count_args(lamlist)); // amount of argument
727 SET_CDR(val, NIL);
728 SET_PROP(val, T); // method-combination default is T
729 SET_AUX(val, cstandard_generic_function);
730 if (illegal_lambda_p(lamlist))
731 error(ILLEGAL_ARGS, "makegeneric", lamlist);
732
733 while (!nullp(body)) {
734 // (:method method-qualifier* parameter-profile form*)
735 if (eqp(caar(body), makesym(":METHOD"))) {
736 if (method_qualifier_p(cadar(body)) && GET_PROP(val) == NIL) {
737 error(ILLEGAL_FORM, "defgeneric", body);
738 }
739 if (symbolp(cadar(body)) && !method_qualifier_p(cadar(body))) {
740 error(ILLEGAL_FORM, "defgeneric", body);
741 }
742 if (listp(cadar(body)) && undef_parameter_p(cadar(body))) {
743 error(UNDEF_ENTITY, "defgeneric", body);
744 }
745 if (listp(cadar(body))
746 && !unified_parameter_p(lamlist, cadar(body))) {
747 error(ILLEGAL_FORM, "defgeneric", body);
748 }
749 if (nullp(cadar(body))) {
750 error(ILLEGAL_FORM, "defgeneric", body);
751 }
752 insert_method(makemethod(cdar(body)), val);
753 } else if (eqp(caar(body), makesym(":METHOD-COMBINATION"))) {
754 if (cadar(body) == NIL || cadar(body) == T)
755 SET_PROP(val, cadar(body));
756 else
757 error(ILLEGAL_FORM, "defgeneric", body);
758 } else if (eqp(caar(body), makesym(":GENERIC-FUNCTION-CLASS"))) {
759 if (!(listp(cadar(body))
760 && eqp(car(cadar(body)), makesym("CLASS")))) {
761 error(ILLEGAL_FORM, "defgeneric", body);
762 }
763 SET_AUX(val, eval(cadar(body)));
764 } else {
765 error(ILLEGAL_FORM, "defgeneric", body);
766 }
767 body = cdr(body);
768 }
769 return (val);
770 }
771
772 /*
773 * diffrence is class. the class is generic-function use in defgeneric*
774 */
775 int
makegeneric_star(int lamlist,int body)776 makegeneric_star(int lamlist, int body)
777 {
778 int val;
779
780 val = hfreshcell();
781 SET_TAG(val, GENERIC);
782 SET_CAR(val, copy_heap(lamlist));
783 SET_OPT(val, count_args(lamlist)); // amount of argument
784 SET_CDR(val, NIL);
785 SET_PROP(val, T); // method-combination default is T
786 SET_AUX(val, cgeneric_function); // difference. only this.
787 while (!nullp(body)) {
788 if (eqp(caar(body), makesym(":METHOD")))
789 insert_method(makemethod(cdar(body)), val);
790
791 body = cdr(body);
792 }
793 return (val);
794 }
795
796
797
798 /*
799 * method car = args&body cdr = environment aux = null opt = priority
800 */
801 int
makemethod(int addr)802 makemethod(int addr)
803 {
804 int val;
805
806 val = hfreshcell();
807 SET_TAG(val, METHOD);
808 if (eqp(car(addr), makesym(":AROUND"))) {
809 SET_CAR(val, copy_heap(cdr(addr)));
810 SET_OPT(val, AROUND);
811 } else if (eqp(car(addr), makesym(":BEFORE"))) {
812 SET_CAR(val, copy_heap(cdr(addr)));
813 SET_OPT(val, BEFORE);
814 } else if (eqp(car(addr), makesym(":AFTER"))) {
815 SET_CAR(val, copy_heap(cdr(addr)));
816 SET_OPT(val, AFTER);
817 } else {
818 SET_CAR(val, copy_heap(addr));
819 SET_OPT(val, PRIMARY);
820 }
821 SET_CDR(val, copy_heap(ep));
822 SET_AUX(val, NIL);
823 return (val);
824 }
825
826
827 int
makestream(FILE * port,int type,const char * name)828 makestream(FILE * port, int type, const char *name)
829 {
830 int addr;
831
832 addr = freshcell();
833 SET_TAG(addr, STREAM);
834 SET_PORT(addr, port);
835 SET_CDR(addr, 0); // string-stream-position
836 SET_AUX(addr, cstream); // class
837 SET_OPT(addr, type); // input/output/inout/EISL_INSTR/EISL_OUTSTR
838 SET_NAME(addr, name);
839 SET_PROP(addr, 0); // output-string-stream charcount from
840 // left
841 return (addr);
842 }
843
844 // --------array-------
845 int
makearray(int ls,int obj)846 makearray(int ls, int obj)
847 {
848 int size,
849 res,
850 i,
851 ls1,
852 *vec;
853
854 ls1 = ls;
855 if (!nullp(ls)) {
856 size = 1;
857 while (!nullp(ls)) {
858 int n;
859
860 n = GET_INT(car(ls));
861 if (n == 0)
862 n = 1;
863 size = n * size;
864 ls = cdr(ls);
865 }
866 size++;
867 } else
868 size = 1;
869
870 res = freshcell();
871 TRY vec = (int *) ALLOC(sizeof(int) * size);
872 EXCEPT(Mem_Failed)
873 error(MALLOC_OVERF, "array", NIL);
874 END_TRY;
875 if (nullp(ls1)) {
876 SET_TAG(res, ARR);
877 SET_CDR(res, ls1);
878 SET_AUX(res, cgeneral_array_star); // class
879 } else if (length(ls1) == 1) {
880 SET_TAG(res, VEC);
881 SET_CDR(res, GET_INT(car(ls1)));
882 SET_AUX(res, cbasic_vector);
883 } else {
884 SET_TAG(res, ARR);
885 SET_CDR(res, ls1);
886 SET_AUX(res, cgeneral_array_star); // class
887 }
888 SET_VEC(res, vec);
889 for (i = 0; i < size; i++)
890 SET_VEC_ELT(res, i, copy(obj));
891
892 return (res);
893 }
894
895
896 int
makestr(const char * string)897 makestr(const char *string)
898 {
899 int addr;
900
901 addr = freshcell();
902 SET_TAG(addr, STR);
903 TRY heap[addr].name = Str_dup(string, 1, 0, 1);
904 EXCEPT(Mem_Failed)
905 error(MALLOC_OVERF, "makestr", NIL);
906 END_TRY;
907 SET_AUX(addr, cstring); // class string
908 return (addr);
909 }
910
911 int
makechar(const char * pname)912 makechar(const char *pname)
913 {
914 int addr,
915 pos;
916 char low_name[SYMSIZE],
917 char_entity;
918
919
920 pos = 0;
921 while (pname[pos] != NUL) {
922 low_name[pos] = tolower(pname[pos]);
923 pos++;
924 }
925 low_name[pos] = NUL;
926 char_entity = pname[0];
927
928 if (strcmp(low_name, "alarm") == 0) {
929 char_entity = BEL;
930 } else if (strcmp(low_name, "backspace") == 0) {
931 char_entity = BS;
932 } else if (strcmp(low_name, "delete") == 0) {
933 char_entity = DEL;
934 } else if (strcmp(low_name, "escape") == 0) {
935 char_entity = ESC;
936 } else if (strcmp(low_name, "return") == 0) {
937 char_entity = RET;
938 } else if (strcmp(low_name, "newline") == 0) {
939 char_entity = EOL;
940 } else if (strcmp(low_name, "null") == 0) {
941 char_entity = NUL;
942 } else if (strcmp(low_name, "space") == 0) {
943 char_entity = SPACE;
944 } else if (strcmp(low_name, "tab") == 0) {
945 char_entity = TAB;
946 }
947
948 addr = freshcell();
949 SET_TAG(addr, CHR);
950 TRY heap[addr].name = (char *) ALLOC(CHARSIZE);
951 EXCEPT(Mem_Failed)
952 error(MALLOC_OVERF, "makechar", NIL);
953 END_TRY;
954 heap[addr].name[0] = char_entity;
955 heap[addr].name[1] = NUL;
956 SET_AUX(addr, ccharacter);
957 return (addr);
958 }
959
960 /*
961 * class obj car = super class cdr = class variable aux = method name =
962 * class name
963 */
964 int
makeclass(const char * pname,int superclass)965 makeclass(const char *pname, int superclass)
966 {
967 int addr;
968
969 addr = freshcell();
970 SET_TAG(addr, CLASS);
971 TRY heap[addr].name = Str_dup(pname, 1, 0, 1);
972 EXCEPT(Mem_Failed)
973 error(MALLOC_OVERF, "makeclass", NIL);
974 END_TRY;
975 SET_CAR(addr, superclass);
976 SET_CDR(addr, NIL);
977 SET_AUX(addr, NIL);
978 return (addr);
979 }
980
981 /*
982 * initls ((format-string a)(format-argments b))...(initarg var) )
983 */
984 int
makeinstance(int cl,int initls)985 makeinstance(int cl, int initls)
986 {
987 int addr;
988
989 addr = freshcell();
990 SET_TAG(addr, INSTANCE);
991 SET_CAR(addr, GET_CAR(cl)); // super class
992 SET_CDR(addr, slotvars(cl)); // slot vars with super class
993 SET_AUX(addr, cl); // class of instance
994 while (!nullp(initls)) {
995 setval(cdr(assq(car(initls), GET_AUX(cl))), cadr(initls),
996 GET_CDR(addr));
997 initls = cddr(initls);
998 }
999 return (addr);
1000 }
1001
1002 int
slotvars(int x)1003 slotvars(int x)
1004 {
1005 if (nullp(x))
1006 return (NIL);
1007 else if (atomp(x) && nullp(GET_CAR(x)))
1008 return (copy(GET_CDR(x)));
1009 else if (atomp(x) && atomp(GET_CAR(x)))
1010 return (append(copy(GET_CDR(x)), copy(GET_CDR(GET_CAR(x)))));
1011 else if (atomp(x) && listp(GET_CAR(x)))
1012 return (append(copy(GET_CDR(x)), slotvars(GET_CAR(x))));
1013 else
1014 return (append(slotvars(GET_AUX(car(x))), slotvars(cdr(x))));
1015 }
1016
1017
1018
1019 // initialize instance
1020 // x is class-instance
1021 // initls is list for initialize value
1022 int
initinst(int x,int initls)1023 initinst(int x, int initls)
1024 {
1025 int cl,
1026 class_vars,
1027 inst_vars,
1028 initargs,
1029 n,
1030 temp;
1031
1032 cl = GET_AUX(x); // class of x
1033 class_vars = GET_CDR(cl); // class variable list. This is assoc list
1034 //
1035 //
1036 //
1037 //
1038 //
1039 //
1040 //
1041 //
1042 // ((initarg1 . accessor1)(initarg2 .
1043 // accesor2)...)
1044 inst_vars = GET_CDR(x); // instance variable list. This is assoc
1045 // list ((accessor1 . val1)(accessor2 .
1046 // val2) ...)
1047 initargs = GET_AUX(cl); // list to set (initarg1 val1 initarg2
1048 // val2 ...)
1049 while (!nullp(class_vars)) {
1050 if ((n = assq(caar(class_vars), inst_vars)) != FAILSE)
1051 SET_CDR(n, copy(cdar(class_vars)));
1052 class_vars = cdr(class_vars);
1053 }
1054 temp = initls;
1055 while (!nullp(initls)) {
1056 if (length(initls) < 2) {
1057 error(WRONG_ARGS, "initinst", initls);
1058 }
1059 n = assq(car(initls), initargs);
1060 if (n != 0 && n != FAILSE) {
1061 int n2 = assq(GET_CDR(n), inst_vars);
1062 if (n2 != 0 && n2 != FAILSE) {
1063 SET_CDR(n2, cadr(initls));
1064 }
1065 }
1066 initls = cddr(initls);
1067 }
1068
1069 SET_CDR(x, initinst1(inst_vars, GET_CAR(cl), temp));
1070 // GET_CAR(cl) is super-class of cl
1071 // temp is initls;
1072 return (x);
1073 }
1074
1075 // initialize variables of super class of instance
1076 int
initinst1(int inst_vars,int sc,int initls)1077 initinst1(int inst_vars, int sc, int initls)
1078 {
1079 int class_vars;
1080
1081
1082 if (nullp(sc))
1083 return (inst_vars);
1084 else if (atomp(sc) && nullp(GET_CAR(GET_AUX(sc)))) { // when
1085 // not
1086 // exist
1087 // super-class
1088 // of
1089 // super-class
1090 class_vars = GET_AUX(GET_AUX(sc));
1091 return (initinst2(inst_vars, class_vars, initls));
1092 } else if (atomp(sc) && !atomp(GET_CAR(GET_AUX(sc)))) { // when
1093 // exists
1094 // super-class
1095 // of
1096 // superclass
1097 class_vars = GET_AUX(GET_AUX(sc));
1098 int temp1;
1099 temp1 = initinst2(inst_vars, class_vars, initls);
1100 int sc1;
1101 sc1 = GET_CAR(GET_AUX(sc));
1102 int temp2;
1103 temp2 =
1104 initinst1(initinst1(temp1, car(sc1), initls), cdr(sc1),
1105 initls);
1106 return (initinst1(temp2, cdr(sc), initls));
1107 } else {
1108 return (initinst1
1109 (initinst1(inst_vars, car(sc), initls), cdr(sc), initls));
1110 }
1111 }
1112
1113 int
initinst2(int inst_vars,int class_vars,int initls)1114 initinst2(int inst_vars, int class_vars, int initls)
1115 {
1116 int n;
1117
1118 while (!nullp(initls)) {
1119 n = assq(car(initls), class_vars);
1120 if (n != 0 && n != FAILSE) {
1121 int n2 = assq(GET_CDR(n), inst_vars);
1122 if (n2 != 0 && n2 != FAILSE) {
1123 SET_CDR(n2, cadr(initls));
1124 }
1125 }
1126 initls = cddr(initls);
1127 }
1128 return (inst_vars);
1129 }
1130
1131 int
makedummy(void)1132 makedummy(void)
1133 {
1134 int res;
1135
1136 res = freshcell();
1137 SET_TAG(res, DUMMY);
1138 SET_AUX(res, cnull);
1139 return (res);
1140 }
1141
1142 // -----for FAST compiler------
1143 int
get_aux(int x)1144 get_aux(int x)
1145 {
1146 return (GET_AUX(x));
1147 }
1148
1149
1150 int
set_car(int x,int y)1151 set_car(int x, int y)
1152 {
1153 SET_CAR(x, y);
1154 return (y);
1155 }
1156
1157 int
set_cdr(int x,int y)1158 set_cdr(int x, int y)
1159 {
1160 SET_CDR(x, y);
1161 return (y);
1162 }
1163
1164 int
set_aux(int x,int y)1165 set_aux(int x, int y)
1166 {
1167 SET_AUX(x, y);
1168 return (y);
1169 }
1170
1171 int
set_opt(int x,int y)1172 set_opt(int x, int y)
1173 {
1174 SET_OPT(x, y);
1175 return (x);
1176 }
1177
1178 int
set_prop(int x,int y)1179 set_prop(int x, int y)
1180 {
1181 SET_PROP(x, y);
1182 return (y);
1183 }
1184
1185 int
set_dynpt(int x)1186 set_dynpt(int x)
1187 {
1188 dp = x;
1189 return (x);
1190 }
1191
1192
1193 int
get_opt(int x)1194 get_opt(int x)
1195 {
1196 return (GET_OPT(x));
1197 }
1198
1199
1200 int
get_prop(int x)1201 get_prop(int x)
1202 {
1203 return (GET_PROP(x));
1204 }
1205
1206 int
get_dynpt(void)1207 get_dynpt(void)
1208 {
1209 return (dp);
1210 }
1211
1212
1213 int
callsubr(int func,int arglist)1214 callsubr(int func, int arglist)
1215 {
1216 return ((GET_SUBR(func)) (arglist));
1217 }
1218
1219 int
makeintlong(int n)1220 makeintlong(int n)
1221 {
1222 int addr;
1223
1224 addr = freshcell();
1225 SET_TAG(addr, LONGN);
1226 SET_LONG(addr, (long long int) n);
1227 SET_AUX(addr, cinteger); // class integer
1228 return (addr);
1229 }
1230
1231 int
makestrflt(const char * str)1232 makestrflt(const char *str)
1233 {
1234 return (makeflt(atof(str)));
1235 }
1236
1237 int
makedoubleflt(double x)1238 makedoubleflt(double x)
1239 {
1240 return (makeflt(x));
1241 }
1242
1243 int
makestrlong(const char * str)1244 makestrlong(const char *str)
1245 {
1246 return (makelong(atol(str)));
1247 }
1248
1249 static inline int
HexDigitToNybble(char c)1250 HexDigitToNybble(char c)
1251 {
1252 if (!isdigit(c)) {
1253 static const int codesToSkip = 'A' - '9' - 1;
1254 c -= codesToSkip;
1255 }
1256 return c - '0';
1257 }
1258
1259 int
makefaststrlong(const char * str)1260 makefaststrlong(const char *str)
1261 {
1262 uint64_t u = 0;
1263 for (int i = 0; i < 8; i++) {
1264 uint8_t hi_nybble = HexDigitToNybble(str[14 - (i << 1)]);
1265 uint8_t lo_nybble = HexDigitToNybble(str[15 - (i << 1)]);
1266 uint64_t byte = (hi_nybble << 4) | lo_nybble;
1267 u |= (byte << (i << 3));
1268 }
1269 return makelong(u);
1270 }
1271
1272 int
nth_cdr(int n,int x)1273 nth_cdr(int n, int x)
1274 {
1275 if (n == 0)
1276 return (x);
1277 else
1278 return (nth_cdr(n - 1, cdr(x)));
1279 }
1280
1281
1282 int
convert(int arg1,int arg2)1283 convert(int arg1, int arg2)
1284 {
1285 char str[SHORT_STRSIZE],
1286 *e;
1287
1288 switch (GET_TAG(arg1)) {
1289 case INTN:
1290 if (GET_AUX(arg2) == cinteger) {
1291 return (arg1);
1292 } else if (GET_AUX(arg2) == ccharacter) {
1293 str[0] = GET_INT(arg1);
1294 str[1] = NUL;
1295 return (makechar(str));
1296 } else if (GET_AUX(arg2) == cfloat) {
1297 return (exact_to_inexact(arg1));
1298 } else if (GET_AUX(arg2) == cstring) {
1299 Fmt_sfmt(str, SHORT_STRSIZE, "%d", GET_INT(arg1));
1300 return (makestr(str));
1301 }
1302 break;
1303 case LONGN:
1304 if (GET_AUX(arg2) == cinteger) {
1305 return (arg1);
1306 } else if (GET_AUX(arg2) == cfloat) {
1307 return (exact_to_inexact(arg1));
1308 } else if (GET_AUX(arg2) == cstring) {
1309 #if __linux || __APPLE__ || defined(__OpenBSD__)
1310 Fmt_sfmt(str, SHORT_STRSIZE, "%D", GET_LONG(arg1));
1311 #endif
1312 #if _WIN32
1313 sprintf(str, "%I64d", GET_LONG(arg1));
1314 #endif
1315 return (makestr(str));
1316 }
1317 break;
1318 case BIGX:
1319 if (GET_AUX(arg2) == cinteger) {
1320 return (arg2);
1321 } else if (GET_AUX(arg2) == cfloat) {
1322 return (exact_to_inexact(arg1));
1323 }
1324 break;
1325 case CHR:
1326 if (GET_AUX(arg2) == cinteger) {
1327 return (makeint(STRING_REF(arg1, 0)));
1328 } else if (GET_AUX(arg2) == csymbol) {
1329 return (makesym(GET_NAME(arg1)));
1330 } else if (GET_AUX(arg2) == cstring) {
1331 return (makestr(GET_NAME(arg1)));
1332 } else if (GET_AUX(arg2) == ccharacter) {
1333 return (arg1);
1334 }
1335 break;
1336 case FLTN:
1337 if (GET_AUX(arg2) == cfloat) {
1338 return (arg1);
1339 } else if (GET_AUX(arg2) == cstring) {
1340 double x;
1341
1342 x = GET_FLT(arg1);
1343 snprintf(str, SHORT_STRSIZE, "%g", x);
1344 return (makestr(str));
1345 }
1346 break;
1347 case SYM:
1348 if (GET_AUX(arg2) == csymbol) {
1349 return (arg1);
1350 } else if (GET_AUX(arg2) == cstring) {
1351 return (makestr(GET_NAME(arg1)));
1352 } else if (nullp(arg1) && GET_AUX(arg2) == cgeneral_vector) {
1353 return (vector(arg1));
1354 } else if (nullp(arg1) && GET_AUX(arg2) == clist) {
1355 return (arg1);
1356 }
1357 break;
1358 case STR:
1359 if (GET_AUX(arg2) == cstring) {
1360 return (arg1);
1361 } else if (GET_AUX(arg2) == cinteger) {
1362 strncpy(stok.buf, GET_NAME(arg1), BUFSIZE - 1);
1363 stok.buf[BUFSIZE - 1] = '\0';
1364
1365 if (bignumtoken(stok.buf)) {
1366 return (makebigx(stok.buf));
1367 } else if (inttoken(stok.buf)) {
1368 return (makeint(strtol(stok.buf, &e, 10)));
1369 } else if (bintoken(stok.buf)) {
1370 return (makeint((int) strtol(stok.buf, &e, 2)));
1371 } else if (octtoken(stok.buf)) {
1372 return (makeint((int) strtol(stok.buf, &e, 8)));
1373 } else if (dectoken(stok.buf)) {
1374 return (makeint((int) strtol(stok.buf, &e, 10)));
1375 } else if (hextoken(stok.buf)) {
1376 return (makeint((int) strtol(stok.buf, &e, 16)));
1377 }
1378 break;
1379 } else if (GET_AUX(arg2) == cfloat) {
1380 if (flttoken(GET_NAME(arg1)))
1381 return (makeflt(atof(GET_NAME(arg1))));
1382 } else if (GET_AUX(arg2) == csymbol) {
1383 return (makesym(GET_NAME(arg1)));
1384 } else if (GET_AUX(arg2) == cgeneral_vector) {
1385 return (string_to_vector(arg1));
1386 } else if (GET_AUX(arg2) == clist) {
1387 return (string_to_list(arg1));
1388 }
1389 break;
1390 case LIS:
1391 if (GET_AUX(arg2) == clist) {
1392 return (arg1);
1393 } else if (GET_AUX(arg2) == cgeneral_vector) {
1394 return (vector(arg1));
1395 }
1396 break;
1397 case VEC:
1398 if (GET_AUX(arg2) == cgeneral_vector) {
1399 return (arg1);
1400 } else if (GET_AUX(arg2) == clist) {
1401 return (vector_to_list(arg1));
1402 }
1403 break;
1404 default:
1405 VL(("convert tag switch default action"));
1406 }
1407 error(OUT_OF_DOMAIN, "convert", arg1);
1408 return (UNDEF);
1409 }
1410
1411 int
a_adaptp(int x,int y)1412 a_adaptp(int x, int y)
1413 {
1414
1415 if (!CELLRANGE(x)) {
1416 // fixnum is immediate. so fixnum data is out of cellrange
1417 if (cfixnum == GET_AUX(y)) // cfixnum is <class fixnum>
1418 return (1);
1419 else if (subclassp(cfixnum, GET_AUX(y)))
1420 return (1);
1421 else
1422 return (0);
1423 }
1424 if (x >= CELLSIZE) {
1425 error(ILLEGAL_ARGS, "a_adaptp", x);
1426 return (0);
1427 } else if (GET_AUX(x) == GET_AUX(y))
1428 return (1);
1429 else if (subclassp(GET_AUX(x), GET_AUX(y)))
1430 return (1);
1431 else
1432 return (0);
1433 }
1434
1435
1436 int
a_matchp(int x,int y)1437 a_matchp(int x, int y)
1438 {
1439
1440 if (!CELLRANGE(x)) {
1441 // when x is out of cell range, x is fixnum
1442 if (cfixnum == GET_AUX(y))
1443 return (1);
1444 else if (GET_OPT(y) == SYSTEM && subclassp(cfixnum, GET_AUX(y)))
1445 // when built-in class, subclass is also eqclass.
1446 return (1);
1447 else
1448 return (0);
1449 }
1450 if (x >= CELLSIZE) {
1451 error(ILLEGAL_ARGS, "a-matchp", x);
1452 return (0);
1453 } else if (GET_AUX(x) == GET_AUX(y))
1454 return (1);
1455 else if (GET_OPT(y) == SYSTEM && subclassp(GET_AUX(x), GET_AUX(y)))
1456 return (1);
1457 else
1458 return (0);
1459 }
1460
1461
1462
1463 int
fast_length(int x)1464 fast_length(int x)
1465 {
1466 int res;
1467
1468 if (!listp(x) && !vectorp(x) && !stringp(x)) {
1469 error(ILLEGAL_ARGS, "length", x);
1470 }
1471
1472 if (listp(x))
1473 res = length(x);
1474 else if (vectorp(x))
1475 res = vector_length(x);
1476 else
1477 res = string_length(x);
1478
1479 return (INT_FLAG | res);
1480 }
1481
1482
1483 int
fast_car(int x)1484 fast_car(int x)
1485 {
1486 if (!(IS_LIST(x)))
1487 error(NOT_LIST, "car", x);
1488 if (IS_NIL(x))
1489 error(NOT_LIST, "car", x);
1490
1491 return (GET_CAR(x));
1492 }
1493
1494
1495 int
fast_cdr(int x)1496 fast_cdr(int x)
1497 {
1498 if (!(IS_LIST(x)))
1499 error(NOT_LIST, "cdr", x);
1500 if (IS_NIL(x))
1501 error(NOT_LIST, "cdr", x);
1502
1503 return (GET_CDR(x));
1504 }
1505
1506
1507 int
set_dynamic(int x,int y)1508 set_dynamic(int x, int y)
1509 {
1510 if (finddyn(x) != FAILSE)
1511 setdynenv(x, y);
1512 else
1513 error(UNDEF_VAR, "set-dynamic", x);
1514
1515 return (y);
1516 }
1517
1518 int
set_catch_symbols(int x)1519 set_catch_symbols(int x)
1520 {
1521 catch_symbols = x;
1522 return (x);
1523 }
1524
1525
1526 char *
get_name(int x)1527 get_name(int x)
1528 {
1529 return (GET_NAME(x));
1530 }
1531
1532 double
get_flt(int x)1533 get_flt(int x)
1534 {
1535 return (GET_FLT(x));
1536 }
1537