19 union value_pointer (*vp_builtin
)(struct stack_slot
*top_of_stack
,
20 struct environment
*env
,
21 union value_pointer rest
);
22 char const *vp_opaque
;
26 union value_pointer name
;
27 union value_pointer value
;
31 struct resource_pool
{
39 struct resource_pool variables
;
40 struct environment
*parent
;
45 union value_pointer car
;
46 union value_pointer cdr
;
51 struct environment
*env
;
52 union value_pointer rest
;
53 union value_pointer retval
;
54 union value_pointer function
;
55 union value_pointer sexpr
;
56 union value_pointer args
;
57 union value_pointer list
;
58 union value_pointer p
;
59 union value_pointer subeval_arg
;
60 union value_pointer
*arglink
;
61 struct environment
*call_env
;
66 struct stack_slot
*prev
;
69 void *resource_get(struct resource_pool
*rp
, int i
);
70 union value_pointer
builtin_lambda(struct stack_slot
*top_of_stack
,
71 struct environment
*env
,
72 union value_pointer rest
);
73 void gc_protect(union value_pointer v
);
74 union value_pointer
gc_unprotect(union value_pointer v
);
76 char const opaque_builtin_function
[] = "builtin-function";
77 char const opaque_builtin_macro
[] = "builtin-macro";
78 char const opaque_user_function
[] = "user-function";
79 char const opaque_user_macro
[] = "user-macro";
80 union value_pointer constant_true
, constant_false
, constant_nil
;
82 struct resource_pool bindings
, charseqs
, environments
, pairs
, stack_slots
;
84 void pointer_mark(union value_pointer
*v
, int type
)
86 int pointer_bits
= v
->vp_int
;
91 v
->vp_int
= pointer_bits
;
94 int pointer_type(union value_pointer v
)
96 return (v
.vp_int
& 3);
99 int get_integer(union value_pointer v
)
101 return (v
.vp_int
>> 2);
104 struct pair
*get_pair(union value_pointer v
)
106 return resource_get(&pairs
, v
.vp_pair
>> 2);
109 struct charseq
*get_charseq(union value_pointer v
)
111 return resource_get(&charseqs
, v
.vp_charseq
>> 2);
114 char *get_charseq_chars(union value_pointer v
)
123 size_t get_charseq_len(union value_pointer v
)
132 void resource_pool_init(struct resource_pool
*rp
, size_t sz
)
134 rp
->resources
= NULL
;
135 rp
->resources_used
= 0;
136 rp
->resources_size
= 0;
140 void resource_pool_free(struct resource_pool
*rp
)
144 for (i
= 0; i
< rp
->resources_used
; i
++) {
145 free(rp
->resources
[i
]);
150 int resource_add(struct resource_pool
*rp
, void *r
)
154 if (rp
->resources_used
>= rp
->resources_size
) {
155 int newsize
= rp
->resources_used
* 2 + 16;
157 for (i
= 0; i
< rp
->resources_used
; i
++) {
158 if (rp
->resources
[i
] == NULL
) {
159 rp
->resources
[i
] = r
;
164 rp
->resources
= realloc(rp
->resources
,
165 sizeof (*rp
->resources
) * newsize
);
166 rp
->resources_size
= newsize
;
169 i
= rp
->resources_used
++;
170 rp
->resources
[i
] = r
;
175 int resource_count(struct resource_pool
*rp
)
177 return rp
->resources_used
;
180 void *resource_get(struct resource_pool
*rp
, int i
)
182 return rp
->resources
[i
];
185 void resource_free(struct resource_pool
*rp
, int i
)
187 free(rp
->resources
[i
]);
188 rp
->resources
[i
] = NULL
;
191 int resource_new_i(struct resource_pool
*rp
)
193 return resource_add(rp
, malloc(rp
->alloc_size
));
196 struct environment
*environment_new(struct environment
*parent
)
198 struct environment
*env
;
201 envnum
= resource_new_i(&environments
);
202 env
= resource_get(&environments
, envnum
);
203 env
->resource_num
= envnum
;
204 resource_pool_init(&env
->variables
, 0);
205 env
->parent
= parent
;
210 void environment_free(struct environment
*env
)
212 resource_pool_free(&env
->variables
);
213 resource_free(&environments
, env
->resource_num
);
216 union value_pointer
charseq_new(char const *s
, size_t len
, size_t size
, int kind
)
218 union value_pointer retval
;
224 for (i
= 0; i
< resource_count(&charseqs
); i
++) {
225 cs
= resource_get(&charseqs
, i
);
226 if (cs
&& len
== cs
->len
&& strncmp(s
, cs
->s
, len
) == 0) {
227 retval
.vp_charseq
= i
<< 2;
228 pointer_mark(&retval
, kind
);
235 retval
.vp_charseq
= resource_new_i(&charseqs
) << 2;
236 pointer_mark(&retval
, kind
);
238 cs
= get_charseq(retval
);
240 cs
->s
= malloc(size
+ 1);
241 memcpy(cs
->s
, s
, len
);
248 union value_pointer
pair_new(void)
250 union value_pointer retval
;
252 retval
.vp_pair
= resource_new_i(&pairs
) << 2;
253 pointer_mark(&retval
, 3);
254 get_pair(retval
)->cdr
= constant_nil
;
255 get_pair(retval
)->gc
= 2;
260 union value_pointer
lisp_car(union value_pointer v
)
262 return get_pair(v
)->car
;
265 union value_pointer
lisp_cdr(union value_pointer v
)
267 return get_pair(v
)->cdr
;
270 int lisp_length(union value_pointer v
)
275 while (pointer_type(v
) == 3 && get_pair(v
) != get_pair(constant_nil
)) {
283 union value_pointer
lisp_cons(union value_pointer left
, union value_pointer right
)
285 union value_pointer retval
;
288 get_pair(retval
)->car
= left
;
289 get_pair(retval
)->cdr
= right
;
290 pointer_mark(&retval
, 3);
292 if (left
.vp_opaque
!= opaque_builtin_function
&&
293 left
.vp_opaque
!= opaque_builtin_macro
) {
294 if (left
.vp_opaque
!= opaque_user_function
&&
295 left
.vp_opaque
!= opaque_user_macro
) {
304 union value_pointer
lisp_integer(int n
)
306 union value_pointer retval
;
308 retval
.vp_int
= n
<< 2;
309 pointer_mark(&retval
, 0);
314 union value_pointer
lisp_opaque(char const *cookie
)
316 union value_pointer retval
;
318 retval
.vp_opaque
= cookie
;
323 union value_pointer
lisp_builtin(union value_pointer (*builtin
)(struct stack_slot
*top_of_stack
,
324 struct environment
*env
,
325 union value_pointer rest
))
327 union value_pointer retval
;
329 retval
.vp_builtin
= builtin
;
334 struct binding
*binding_new(struct environment
*env
,
336 union value_pointer value
)
341 bnum
= resource_new_i(&bindings
);
342 b
= resource_get(&bindings
, bnum
);
343 b
->resource_num
= bnum
;
344 b
->name
= charseq_new(name
, strlen(name
), strlen(name
), 1);
347 resource_add(&env
->variables
, b
);
349 gc_unprotect(b
->name
);
350 gc_unprotect(b
->value
);
355 union value_pointer
builtin_new(char const *opaque_type
,
356 union value_pointer (*builtin
)(struct stack_slot
*top_of_stack
,
357 struct environment
*env
,
358 union value_pointer rest
))
360 return lisp_cons(lisp_opaque(opaque_type
),
361 lisp_builtin(builtin
));
364 size_t parse_word(union value_pointer
*vp
, char const *buf
, size_t len
)
369 for (n
= 0, i
= 0; i
< len
; i
++) {
370 if (buf
[i
] < '0' || buf
[i
] > '9') {
373 n
= n
*10 + buf
[i
] - '0';
386 for (i
++; i
< len
; i
++) {
399 *vp
= charseq_new(buf
, i
, i
, 1);
409 size_t parse_string(union value_pointer
*vp
, char const *buf
, size_t len
)
415 for (backslash
= n
= 0, i
= 1; i
< len
; i
++) {
419 } else if (buf
[i
] == '"') {
421 } else if (buf
[i
] == '\\') {
429 *vp
= charseq_new(buf
+ 1, n
, n
, 2);
432 for (backslash
= 0, i
= 1, s
= get_charseq_chars(*vp
); i
< len
; i
++) {
443 } else if (buf
[i
] == '\\') {
453 size_t parse_forms(char const *buf
, size_t len
, union value_pointer
*form
)
458 for (i
= 0; i
< len
; i
++) {
459 char const c
= buf
[i
];
460 union value_pointer u
, v
;
467 n
= parse_forms(buf
+ i
+ 1, len
- i
- 1, &u
) + 1;
472 v
= lisp_cons(u
, constant_nil
);
475 form
= &get_pair(*form
)->cdr
;
485 n
= parse_string(&get_pair(v
)->car
, buf
+ i
, len
- i
);
489 pointer_mark(form
, 3);
490 form
= &get_pair(v
)->cdr
;
493 n
= parse_word(&u
, buf
+ i
, len
- i
);
494 if (pointer_type(u
) == 1 &&
495 strcmp(get_charseq_chars(u
), ".") == 0) {
501 *form
= lisp_cons(u
, constant_nil
);
503 form
= &get_pair(*form
)->cdr
;
518 void pretty_print(union value_pointer v
)
520 union value_pointer i
;
523 switch (pointer_type(v
)) {
525 printf("%d", get_integer(v
));
528 printf("%s", get_charseq_chars(v
));
531 printf("\"%s\"", get_charseq_chars(v
));
535 if (p
!= get_pair(constant_nil
) &&
536 (p
->car
.vp_opaque
== opaque_builtin_function
||
537 p
->car
.vp_opaque
== opaque_builtin_macro
||
538 p
->car
.vp_opaque
== opaque_user_function
||
539 p
->car
.vp_opaque
== opaque_user_macro
)) {
540 printf("%s", p
->car
.vp_opaque
);
546 pointer_type(i
) == 3 && get_pair(i
) != get_pair(constant_nil
);
548 if (i
.vp_pair
!= v
.vp_pair
) {
551 pretty_print(lisp_car(i
));
553 if (pointer_type(i
) != 3) {
562 struct stack_slot
*stack_call(struct stack_slot
*top_of_stack
,
563 struct environment
*env
,
564 union value_pointer rest
)
566 struct stack_slot
*slot
;
569 slotnum
= resource_new_i(&stack_slots
);
570 slot
= resource_get(&stack_slots
, slotnum
);
571 slot
->resource_num
= slotnum
;
572 slot
->evaluating
= 1;
573 slot
->return_path
= 4040;
576 slot
->prev
= top_of_stack
;
582 struct stack_slot
*stack_return(struct stack_slot
*top_of_stack
)
584 struct stack_slot
*slot
;
586 slot
= top_of_stack
->prev
;
588 resource_free(&stack_slots
, top_of_stack
->resource_num
);
593 union value_pointer
eval_symbol(struct environment
*env
, union value_pointer sym
)
595 char const *symbol_name
;
598 symbol_name
= get_charseq_chars(sym
);
600 for (i
= 0; i
< resource_count(&env
->variables
); i
++) {
603 b
= resource_get(&env
->variables
, i
);
604 if (strcmp(get_charseq_chars(b
->name
), symbol_name
) == 0) {
609 } while (env
!= NULL
);
614 union value_pointer
builtin_eval(struct stack_slot
*caller
,
615 struct environment
*env_toplevel
,
616 union value_pointer rest_toplevel
)
618 struct stack_slot
*top_of_stack
;
619 union value_pointer element
;
620 union value_pointer consequent
, alternate
;
621 union value_pointer retval
;
622 struct pair
*closure
;
624 top_of_stack
= stack_call(caller
, env_toplevel
, rest_toplevel
);
625 top_of_stack
->return_path
= 0;
628 if (top_of_stack
->evaluating
) {
629 switch (pointer_type(lisp_car(top_of_stack
->rest
))) {
632 top_of_stack
->retval
= lisp_car(top_of_stack
->rest
);
635 top_of_stack
->retval
= eval_symbol(top_of_stack
->env
,
636 lisp_car(top_of_stack
->rest
));
639 top_of_stack
->list
= lisp_car(top_of_stack
->rest
);
640 top_of_stack
->subeval_arg
= lisp_cons(lisp_car(top_of_stack
->list
), constant_nil
);
642 top_of_stack
= stack_call(top_of_stack
,
644 top_of_stack
->subeval_arg
);
645 top_of_stack
->return_path
= 3;
649 switch (top_of_stack
->return_path
) {
651 retval
= top_of_stack
->retval
;
652 stack_return(top_of_stack
);
655 retval
= top_of_stack
->retval
;
656 top_of_stack
= stack_return(top_of_stack
);
657 top_of_stack
->retval
= retval
;
658 gc_unprotect(top_of_stack
->sexpr
);
659 top_of_stack
->p
= lisp_cdr(top_of_stack
->p
);
660 if (get_pair(top_of_stack
->p
) != get_pair(constant_nil
)) {
661 top_of_stack
->sexpr
= lisp_cons(lisp_car(top_of_stack
->p
), constant_nil
);
662 if (get_pair(lisp_cdr(top_of_stack
->p
)) == get_pair(constant_nil
)) {
663 top_of_stack
->env
= top_of_stack
->call_env
;
664 top_of_stack
->rest
= top_of_stack
->sexpr
;
667 top_of_stack
= stack_call(top_of_stack
,
668 top_of_stack
->call_env
,
669 top_of_stack
->sexpr
);
670 top_of_stack
->return_path
= 1;
673 environment_free(top_of_stack
->call_env
);
674 gc_unprotect(top_of_stack
->list
);
677 top_of_stack
->prev
->args
= lisp_cons(top_of_stack
->retval
, constant_nil
);
678 top_of_stack
= stack_return(top_of_stack
);
679 gc_unprotect(top_of_stack
->subeval_arg
);
681 if (lisp_car(lisp_car(top_of_stack
->args
)).vp_opaque
== opaque_builtin_function
||
682 lisp_car(lisp_car(top_of_stack
->args
)).vp_opaque
== opaque_user_function
) {
683 top_of_stack
->arglink
= &get_pair(top_of_stack
->args
)->cdr
;
685 top_of_stack
->list
= lisp_cdr(top_of_stack
->list
);
689 element
= lisp_cons(top_of_stack
->retval
, constant_nil
);
690 top_of_stack
= stack_return(top_of_stack
);
691 gc_unprotect(top_of_stack
->subeval_arg
);
693 *top_of_stack
->arglink
= element
;
694 top_of_stack
->arglink
= &get_pair(element
)->cdr
;
696 gc_unprotect(element
);
697 top_of_stack
->list
= lisp_cdr(top_of_stack
->list
);
699 if (get_pair(top_of_stack
->list
) != get_pair(constant_nil
)) {
700 top_of_stack
->subeval_arg
= lisp_cons(lisp_car(top_of_stack
->list
),
703 top_of_stack
= stack_call(top_of_stack
,
705 top_of_stack
->subeval_arg
);
706 top_of_stack
->return_path
= 4;
710 get_pair(top_of_stack
->args
)->cdr
= lisp_cdr(top_of_stack
->list
);
713 top_of_stack
->list
= top_of_stack
->args
;
714 top_of_stack
->function
= lisp_car(top_of_stack
->list
);
715 top_of_stack
->args
= lisp_cdr(top_of_stack
->list
);
717 closure
= get_pair(top_of_stack
->function
);
718 if (closure
->car
.vp_opaque
== opaque_builtin_function
||
719 closure
->car
.vp_opaque
== opaque_builtin_macro
) {
720 top_of_stack
= stack_call(top_of_stack
,
723 top_of_stack
->return_path
= 6;
724 top_of_stack
->retval
= (*closure
->cdr
.vp_builtin
)(top_of_stack
,
725 top_of_stack
->prev
->env
,
726 top_of_stack
->prev
->args
);
728 } else if (closure
->car
.vp_opaque
== opaque_user_function
) {
729 union value_pointer function_env
;
730 union value_pointer formal_args
;
731 union value_pointer function_body
;
732 struct environment
*lambda_env
;
734 top_of_stack
->p
= closure
->cdr
;
735 function_env
= lisp_car(top_of_stack
->p
);
736 formal_args
= lisp_car(lisp_cdr(top_of_stack
->p
));
737 function_body
= lisp_cdr(lisp_cdr(top_of_stack
->p
));
739 lambda_env
= resource_get(&environments
,
740 get_integer(function_env
));
741 top_of_stack
->call_env
= environment_new(lambda_env
);
742 for (top_of_stack
->p
= formal_args
;
743 (pointer_type(top_of_stack
->p
) == 3 &&
744 get_pair(top_of_stack
->p
) != get_pair(constant_nil
) &&
745 get_pair(top_of_stack
->args
) != get_pair(constant_nil
));
746 top_of_stack
->p
= lisp_cdr(top_of_stack
->p
),
747 top_of_stack
->args
= lisp_cdr(top_of_stack
->args
)) {
748 binding_new(top_of_stack
->call_env
,
749 get_charseq_chars(lisp_car(top_of_stack
->p
)),
750 lisp_car(top_of_stack
->args
));
752 if (pointer_type(top_of_stack
->p
) == 1) {
753 binding_new(top_of_stack
->call_env
,
754 get_charseq_chars(top_of_stack
->p
),
758 top_of_stack
->p
= function_body
;
759 if (get_pair(top_of_stack
->p
) != get_pair(constant_nil
)) {
760 top_of_stack
->sexpr
= lisp_cons(lisp_car(top_of_stack
->p
), constant_nil
);
761 if (get_pair(lisp_cdr(top_of_stack
->p
)) == get_pair(constant_nil
)) {
762 top_of_stack
->env
= top_of_stack
->call_env
;
763 top_of_stack
->rest
= top_of_stack
->sexpr
;
766 top_of_stack
= stack_call(top_of_stack
,
767 top_of_stack
->call_env
,
768 top_of_stack
->sexpr
);
769 top_of_stack
->return_path
= 1;
772 environment_free(top_of_stack
->call_env
);
775 gc_unprotect(top_of_stack
->list
);
778 retval
= top_of_stack
->retval
;
779 top_of_stack
= stack_return(top_of_stack
);
780 top_of_stack
->retval
= retval
;
781 gc_unprotect(top_of_stack
->list
);
784 top_of_stack
->return_path
= 8;
785 top_of_stack
->evaluating
= 1;
788 retval
= top_of_stack
->retval
;
789 gc_unprotect(top_of_stack
->rest
);
790 top_of_stack
= stack_return(top_of_stack
);
792 consequent
= lisp_car(lisp_cdr(lisp_cdr(lisp_car(top_of_stack
->rest
))));
793 alternate
= lisp_cdr(lisp_cdr(lisp_cdr(lisp_car(top_of_stack
->rest
))));
794 if (pointer_type(retval
) != 1 ||
795 retval
.vp_charseq
!= constant_false
.vp_charseq
) {
796 element
= lisp_cons(consequent
, constant_nil
);
797 } else if (get_pair(alternate
) != get_pair(constant_nil
)) {
798 element
= lisp_cons(lisp_car(alternate
), constant_nil
);
800 top_of_stack
->retval
= constant_nil
;
804 gc_unprotect(retval
);
805 top_of_stack
->rest
= element
;
806 top_of_stack
->evaluating
= 1;
809 top_of_stack
->evaluating
= 0;
813 union value_pointer
builtin_string_to_list(struct stack_slot
*top_of_stack
,
814 struct environment
*env
,
815 union value_pointer rest
)
817 union value_pointer retval
;
818 union value_pointer
*v
;
822 s
= get_charseq_chars(lisp_car(rest
));
823 n
= get_charseq_len(lisp_car(rest
));
824 retval
= lisp_cons(constant_nil
, constant_nil
);
825 v
= &get_pair(retval
)->cdr
;
826 for (i
= 0; i
< n
; i
++) {
827 *v
= lisp_cons(lisp_integer(s
[i
]), constant_nil
);
829 v
= &get_pair(*v
)->cdr
;
831 v
= &get_pair(retval
)->cdr
;
833 gc_unprotect(retval
);
839 union value_pointer
builtin_car(struct stack_slot
*top_of_stack
,
840 struct environment
*env
,
841 union value_pointer rest
)
843 return lisp_car(lisp_car(rest
));
846 union value_pointer
builtin_cdr(struct stack_slot
*top_of_stack
,
847 struct environment
*env
,
848 union value_pointer rest
)
850 return lisp_cdr(lisp_car(rest
));
853 union value_pointer
builtin_cons(struct stack_slot
*top_of_stack
,
854 struct environment
*env
,
855 union value_pointer rest
)
857 return gc_unprotect(lisp_cons(lisp_car(rest
), lisp_car(lisp_cdr(rest
))));
860 union value_pointer
builtin_eq_p(struct stack_slot
*top_of_stack
,
861 struct environment
*env
,
862 union value_pointer rest
)
864 union value_pointer a
, b
;
867 b
= lisp_car(lisp_cdr(rest
));
869 if (pointer_type(a
) != pointer_type(b
)) {
870 return constant_false
;
873 switch (pointer_type(a
)) {
875 if (get_integer(a
) != get_integer(b
)) {
876 return constant_false
;
881 if (get_charseq(a
) != get_charseq(b
)) {
882 return constant_false
;
886 if (a
.vp_pair
!= b
.vp_pair
) {
887 return constant_false
;
892 return constant_true
;
895 union value_pointer
builtin_display(struct stack_slot
*top_of_stack
,
896 struct environment
*env
,
897 union value_pointer rest
)
899 pretty_print(lisp_car(rest
));
901 return constant_true
;
904 union value_pointer
builtin_list_p_helper(union value_pointer v
)
906 if (pointer_type(v
) == 3) {
907 if (get_pair(v
) == get_pair(constant_nil
)) {
908 return constant_true
;
910 return builtin_list_p_helper(lisp_cdr(v
));
913 return constant_false
;
917 union value_pointer
builtin_list_p(struct stack_slot
*top_of_stack
,
918 struct environment
*env
,
919 union value_pointer rest
)
921 return builtin_list_p_helper(lisp_car(rest
));
924 union value_pointer
builtin_define(struct stack_slot
*top_of_stack
,
925 struct environment
*env
,
926 union value_pointer rest
)
928 union value_pointer name_and_args
, definition
;
929 union value_pointer lambda_args
, function
;
931 name_and_args
= lisp_car(rest
);
932 definition
= lisp_car(lisp_cdr(rest
));
934 lambda_args
= lisp_cons(lisp_cdr(name_and_args
), lisp_cons(definition
, constant_nil
));
936 function
= builtin_lambda(top_of_stack
, env
, lambda_args
);
937 gc_unprotect(lambda_args
);
939 binding_new(env
, get_charseq_chars(lisp_car(name_and_args
)), function
);
944 union value_pointer
builtin_if(struct stack_slot
*top_of_stack
,
945 struct environment
*env
,
946 union value_pointer rest
)
948 union value_pointer retval
;
949 union value_pointer condition
, consequent
, alternate
;
950 union value_pointer v
;
952 retval
= constant_nil
;
954 condition
= lisp_car(rest
);
955 consequent
= lisp_car(lisp_cdr(rest
));
956 alternate
= lisp_cdr(lisp_cdr(rest
));
958 v
= lisp_cons(condition
, constant_nil
);
960 top_of_stack
->rest
= v
;
961 top_of_stack
->return_path
= 7;
964 condition
= builtin_eval(top_of_stack
, env
, v
);
967 if (pointer_type(condition
) != 1 ||
968 condition
.vp_charseq
!= constant_false
.vp_charseq
) {
969 v
= lisp_cons(consequent
, constant_nil
);
970 } else if (get_pair(alternate
) != get_pair(constant_nil
)) {
971 v
= lisp_cons(lisp_car(alternate
), constant_nil
);
976 gc_unprotect(condition
);
977 retval
= builtin_eval(top_of_stack
, env
, v
);
983 union value_pointer
builtin_lambda(struct stack_slot
*top_of_stack
,
984 struct environment
*env
,
985 union value_pointer rest
)
987 union value_pointer retval
;
989 retval
= lisp_cons(lisp_opaque(opaque_user_function
),
990 lisp_cons(lisp_integer(env
->resource_num
), rest
));
991 pointer_mark(&retval
, 3);
996 union value_pointer
builtin_quote(struct stack_slot
*top_of_stack
,
997 struct environment
*env
,
998 union value_pointer rest
)
1000 return lisp_car(rest
);
1003 union value_pointer
builtin_plus(struct stack_slot
*top_of_stack
,
1004 struct environment
*env
,
1005 union value_pointer rest
)
1007 union value_pointer retval
;
1010 for (sum
= 0; get_pair(rest
) != get_pair(constant_nil
); rest
= lisp_cdr(rest
)) {
1011 sum
+= get_integer(lisp_car(rest
));
1014 retval
.vp_int
= sum
<< 2;
1015 pointer_mark(&retval
, 0);
1020 union value_pointer
builtin_minus(struct stack_slot
*top_of_stack
,
1021 struct environment
*env
,
1022 union value_pointer rest
)
1024 union value_pointer retval
;
1025 union value_pointer lhs
;
1028 lhs
= lisp_car(rest
);
1029 rest
= lisp_cdr(rest
);
1030 difference
= get_integer(lhs
);
1031 if (get_pair(rest
) != get_pair(constant_nil
)) {
1032 for (difference
= get_integer(lhs
);
1033 get_pair(rest
) != get_pair(constant_nil
);
1034 rest
= lisp_cdr(rest
)) {
1035 difference
-= get_integer(lisp_car(rest
));
1038 difference
= -get_integer(lhs
);
1041 retval
.vp_int
= difference
<< 2;
1042 pointer_mark(&retval
, 0);
1046 void gc_mark(union value_pointer v
)
1048 switch (pointer_type(v
)) {
1052 get_charseq(v
)->gc
|= 1;
1060 if (p
->car
.vp_opaque
!= opaque_builtin_function
&&
1061 p
->car
.vp_opaque
!= opaque_builtin_macro
) {
1062 if (p
->car
.vp_opaque
!= opaque_user_function
&&
1063 p
->car
.vp_opaque
!= opaque_user_macro
) {
1064 gc_mark(lisp_car(v
));
1066 gc_mark(lisp_cdr(v
));
1072 void gc_protect(union value_pointer v
)
1074 switch (pointer_type(v
)) {
1078 get_charseq(v
)->gc
|= 2;
1088 union value_pointer
gc_unprotect(union value_pointer v
)
1090 switch (pointer_type(v
)) {
1094 get_charseq(v
)->gc
&= ~2;
1105 void gc_unmark_all(void)
1109 for (j
= 0; j
< resource_count(&charseqs
); j
++) {
1110 struct charseq
*cs
= resource_get(&charseqs
, j
);
1115 for (j
= 0; j
< resource_count(&pairs
); j
++) {
1116 struct pair
*p
= resource_get(&pairs
, j
);
1121 for (j
= 0; j
< resource_count(&pairs
); j
++) {
1122 struct pair
*p
= resource_get(&pairs
, j
);
1124 if (p
->car
.vp_opaque
!= opaque_builtin_function
&&
1125 p
->car
.vp_opaque
!= opaque_builtin_macro
) {
1126 if (p
->car
.vp_opaque
!= opaque_user_function
&&
1127 p
->car
.vp_opaque
!= opaque_user_macro
) {
1136 void gc_collect(struct environment
*env
)
1142 for (; env
; env
= env
->parent
) {
1143 for (j
= 0; j
< resource_count(&env
->variables
); j
++) {
1144 struct binding
*b
= resource_get(&env
->variables
, j
);
1153 for (j
= 0; j
< resource_count(&charseqs
); j
++) {
1154 struct charseq
*cs
= resource_get(&charseqs
, j
);
1155 if (cs
&& cs
->gc
== 0) {
1157 resource_free(&charseqs
, j
);
1160 for (j
= 0; j
< resource_count(&pairs
); j
++) {
1161 struct pair
*p
= resource_get(&pairs
, j
);
1162 if (p
&& p
->gc
== 0) {
1163 resource_free(&pairs
, j
);
1174 union value_pointer i
, form
;
1175 struct environment
*top_env
;
1178 resource_pool_init(&bindings
, sizeof (struct binding
));
1179 resource_pool_init(&charseqs
, sizeof (struct charseq
));
1180 resource_pool_init(&environments
, sizeof (struct environment
));
1181 resource_pool_init(&pairs
, sizeof (struct pair
));
1182 resource_pool_init(&stack_slots
, sizeof (struct stack_slot
));
1184 constant_nil
= pair_new();
1185 get_pair(constant_nil
)->car
= constant_nil
;
1186 get_pair(constant_nil
)->cdr
= constant_nil
;
1188 while (!feof(stdin
) && !ferror(stdin
)) {
1191 if (bufused
>= bufsize
) {
1192 buf
= realloc(buf
, bufsize
* 2 + 16);
1196 bufsize
= bufsize
* 2 + 16;
1198 n
= fread(buf
+ bufused
, 1, bufsize
- bufused
, stdin
);
1202 top_env
= environment_new(NULL
);
1204 constant_true
= charseq_new("#t", 2, 2, 1);
1205 constant_false
= charseq_new("#f", 2, 2, 1);
1207 binding_new(top_env
, "#t", constant_true
);
1208 binding_new(top_env
, "#f", constant_false
);
1210 binding_new(top_env
, "car", builtin_new(opaque_builtin_function
, builtin_car
));
1211 binding_new(top_env
, "cdr", builtin_new(opaque_builtin_function
, builtin_cdr
));
1212 binding_new(top_env
, "cons", builtin_new(opaque_builtin_function
, builtin_cons
));
1213 binding_new(top_env
, "eq?", builtin_new(opaque_builtin_function
, builtin_eq_p
));
1214 binding_new(top_env
, "display", builtin_new(opaque_builtin_function
, builtin_display
));
1215 binding_new(top_env
, "list?", builtin_new(opaque_builtin_function
, builtin_list_p
));
1216 binding_new(top_env
, "primitive-eval", builtin_new(opaque_builtin_function
, builtin_eval
));
1217 binding_new(top_env
, "string->list", builtin_new(opaque_builtin_function
, builtin_string_to_list
));
1219 binding_new(top_env
, "define", builtin_new(opaque_builtin_macro
, builtin_define
));
1220 binding_new(top_env
, "if", builtin_new(opaque_builtin_macro
, builtin_if
));
1221 binding_new(top_env
, "lambda", builtin_new(opaque_builtin_macro
, builtin_lambda
));
1222 binding_new(top_env
, "quote", builtin_new(opaque_builtin_macro
, builtin_quote
));
1224 binding_new(top_env
, "+", builtin_new(opaque_builtin_function
, builtin_plus
));
1225 binding_new(top_env
, "-", builtin_new(opaque_builtin_function
, builtin_minus
));
1227 form
= lisp_cons(constant_nil
, constant_nil
);
1229 formsize
= parse_forms(buf
, bufused
, &get_pair(form
)->cdr
);
1231 form
= lisp_cdr(form
);
1235 if (formsize
!= bufused
) {
1236 printf("this stuff left over: \"%.*s\"\n",
1237 bufused
- formsize
, buf
+ formsize
);
1240 for (i
= form
; get_pair(i
) != get_pair(constant_nil
); i
= form
) {
1241 union value_pointer rest
, retval
;
1243 rest
= lisp_cons(lisp_car(i
), constant_nil
);
1245 pretty_print(lisp_car(i
));
1247 retval
= builtin_eval(NULL
, top_env
, rest
);
1249 pretty_print(retval
);
1250 gc_unprotect(retval
);
1257 gc_collect(top_env
);
1260 environment_free(top_env
);
1262 gc_unprotect(constant_nil
);
1265 resource_pool_free(&charseqs
);
1266 resource_pool_free(&pairs
);
1267 free(bindings
.resources
);
1268 free(environments
.resources
);