X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_stack.c;h=d3b5d4b71f783e87ae5b53b0a3f614651f584206;hb=4b52fc6eea9a478cb3dd42dcd32c92838df39734;hp=d19dd6d6d59f1226979041fc278b384c9e77a712;hpb=195cbeec19a6a44f309a9040d727d37fe4e2ec97;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c
index d19dd6d6..d3b5d4b7 100644
--- a/src/scheme/ao_scheme_stack.c
+++ b/src/scheme/ao_scheme_stack.c
@@ -28,11 +28,11 @@ stack_mark(void *addr)
 {
 	struct ao_scheme_stack	*stack = addr;
 	for (;;) {
-		ao_scheme_poly_mark(stack->sexprs, 0);
-		ao_scheme_poly_mark(stack->values, 0);
+		ao_scheme_poly_mark(stack->sexprs, 1);
+		ao_scheme_poly_mark(stack->values, 1);
 		/* no need to mark values_tail */
 		ao_scheme_poly_mark(stack->frame, 0);
-		ao_scheme_poly_mark(stack->list, 0);
+		ao_scheme_poly_mark(stack->list, 1);
 		stack = ao_scheme_poly_stack(stack->prev);
 		if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack))
 			break;
@@ -47,11 +47,11 @@ stack_move(void *addr)
 	while (stack) {
 		struct ao_scheme_stack	*prev;
 		int			ret;
-		(void) ao_scheme_poly_move(&stack->sexprs, 0);
-		(void) ao_scheme_poly_move(&stack->values, 0);
+		(void) ao_scheme_poly_move(&stack->sexprs, 1);
+		(void) ao_scheme_poly_move(&stack->values, 1);
 		(void) ao_scheme_poly_move(&stack->values_tail, 0);
 		(void) ao_scheme_poly_move(&stack->frame, 0);
-		(void) ao_scheme_poly_move(&stack->list, 0);
+		(void) ao_scheme_poly_move(&stack->list, 1);
 		prev = ao_scheme_poly_stack(stack->prev);
 		if (!prev)
 			break;
@@ -150,34 +150,35 @@ ao_scheme_stack_pop(void)
 }
 
 void
-ao_scheme_stack_clear(void)
+ao_scheme_stack_write(FILE *out, ao_poly poly, bool write)
 {
-	ao_scheme_stack = NULL;
-	ao_scheme_frame_current = NULL;
-	ao_scheme_v = AO_SCHEME_NIL;
-}
-
-void
-ao_scheme_stack_write(ao_poly poly)
-{
-	struct ao_scheme_stack *s = ao_scheme_poly_stack(poly);
+	struct ao_scheme_stack 	*s = ao_scheme_poly_stack(poly);
+	struct ao_scheme_stack	*clear = s;
+	int			written = 0;
 
+	(void) write;
+	ao_scheme_print_start();
+	ao_scheme_frame_print_indent += 2;
 	while (s) {
-		if (s->type & AO_SCHEME_STACK_PRINT) {
-			printf("[recurse...]");
-			return;
+		if (ao_scheme_print_mark_addr(s)) {
+			fputs("[recurse...]", out);
+			break;
 		}
-		s->type |= AO_SCHEME_STACK_PRINT;
-		printf("\t[\n");
-		printf("\t\texpr:   "); ao_scheme_poly_write(s->list); printf("\n");
-		printf("\t\tstate:  %s\n", ao_scheme_state_names[s->state]);
-		ao_scheme_error_poly ("values: ", s->values, s->values_tail);
-		ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL);
-		ao_scheme_error_frame(2, "frame:  ", ao_scheme_poly_frame(s->frame));
-		printf("\t]\n");
-		s->type &= ~AO_SCHEME_STACK_PRINT;
+		written++;
+		fputs("\t[\n", out);
+		ao_scheme_fprintf(out, "\t\texpr:     %v\n", s->list);
+		ao_scheme_fprintf(out, "\t\tvalues:   %v\n", s->values);
+		ao_scheme_fprintf(out, "\t\tframe:    %v\n", s->frame);
+		fputs("\t]\n", out);
 		s = ao_scheme_poly_stack(s->prev);
 	}
+	ao_scheme_frame_print_indent -= 2;
+	if (ao_scheme_print_stop()) {
+		while (written--) {
+			ao_scheme_print_clear_addr(clear);
+			clear = ao_scheme_poly_stack(clear->prev);
+		}
+	}
 }
 
 /*
@@ -190,13 +191,13 @@ ao_scheme_stack_copy(struct ao_scheme_stack *old)
 	struct ao_scheme_stack *n, *prev = NULL;
 
 	while (old) {
-		ao_scheme_stack_stash(0, old);
-		ao_scheme_stack_stash(1, new);
-		ao_scheme_stack_stash(2, prev);
+		ao_scheme_stack_stash(old);
+		ao_scheme_stack_stash(new);
+		ao_scheme_stack_stash(prev);
 		n = ao_scheme_stack_new();
-		prev = ao_scheme_stack_fetch(2);
-		new = ao_scheme_stack_fetch(1);
-		old = ao_scheme_stack_fetch(0);
+		prev = ao_scheme_stack_fetch();
+		new = ao_scheme_stack_fetch();
+		old = ao_scheme_stack_fetch();
 		if (!n)
 			return NULL;
 
@@ -221,11 +222,12 @@ ao_scheme_stack_copy(struct ao_scheme_stack *old)
 ao_poly
 ao_scheme_stack_eval(void)
 {
+	struct ao_scheme_cons	*cons;
 	struct ao_scheme_stack	*new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
 	if (!new)
 		return AO_SCHEME_NIL;
 
-	struct ao_scheme_cons	*cons = ao_scheme_poly_cons(ao_scheme_stack->values);
+	cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 
 	if (!cons || !cons->cdr)
 		return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
@@ -248,21 +250,19 @@ ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
 	struct ao_scheme_stack	*new;
 	ao_poly			v;
 
-	/* Make sure the single parameter is a lambda */
-	if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1))
-		return AO_SCHEME_NIL;
-	if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0))
+	if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons,
+				  AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v,
+				  AO_SCHEME_ARG_END))
 		return AO_SCHEME_NIL;
 
-	/* go get the lambda */
-	ao_scheme_v = ao_scheme_arg(cons, 0);
-
+	ao_scheme_poly_stash(v);
 	/* Note that the whole call chain now has
 	 * a reference to it which may escape
 	 */
 	new = ao_scheme_stack_copy(ao_scheme_stack);
 	if (!new)
 		return AO_SCHEME_NIL;
+	v = ao_scheme_poly_fetch();
 
 	/* re-fetch cons after the allocation */
 	cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
@@ -273,8 +273,7 @@ ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
 
 	cons->car = ao_scheme_stack_poly(new);
 	cons->cdr = AO_SCHEME_NIL;
-	v = ao_scheme_lambda_eval();
-	ao_scheme_stack->sexprs = v;
-	ao_scheme_stack->state = eval_begin;
-	return AO_SCHEME_NIL;
+
+	ao_scheme_stack->state = eval_exec;
+	return v;
 }