2 * Copyright © 2016 Keith Packard <keithp@keithp.com>
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation, either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * General Public License for more details.
15 #include "ao_scheme.h"
17 const struct ao_scheme_type ao_scheme_stack_type;
20 stack_size(void *addr)
23 return sizeof (struct ao_scheme_stack);
27 stack_mark(void *addr)
29 struct ao_scheme_stack *stack = addr;
31 ao_scheme_poly_mark(stack->sexprs, 0);
32 ao_scheme_poly_mark(stack->values, 0);
33 /* no need to mark values_tail */
34 ao_scheme_poly_mark(stack->frame, 0);
35 ao_scheme_poly_mark(stack->list, 0);
36 stack = ao_scheme_poly_stack(stack->prev);
37 if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack))
43 stack_move(void *addr)
45 struct ao_scheme_stack *stack = addr;
48 struct ao_scheme_stack *prev;
50 (void) ao_scheme_poly_move(&stack->sexprs, 0);
51 (void) ao_scheme_poly_move(&stack->values, 0);
52 (void) ao_scheme_poly_move(&stack->values_tail, 0);
53 (void) ao_scheme_poly_move(&stack->frame, 0);
54 (void) ao_scheme_poly_move(&stack->list, 0);
55 prev = ao_scheme_poly_stack(stack->prev);
58 ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev);
59 if (prev != ao_scheme_poly_stack(stack->prev))
60 stack->prev = ao_scheme_stack_poly(prev);
67 const struct ao_scheme_type ao_scheme_stack_type = {
74 struct ao_scheme_stack *ao_scheme_stack_free_list;
77 ao_scheme_stack_reset(struct ao_scheme_stack *stack)
79 stack->state = eval_sexpr;
80 stack->sexprs = AO_SCHEME_NIL;
81 stack->values = AO_SCHEME_NIL;
82 stack->values_tail = AO_SCHEME_NIL;
85 static struct ao_scheme_stack *
86 ao_scheme_stack_new(void)
88 struct ao_scheme_stack *stack;
90 if (ao_scheme_stack_free_list) {
91 stack = ao_scheme_stack_free_list;
92 ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev);
94 stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack));
97 stack->type = AO_SCHEME_STACK;
99 ao_scheme_stack_reset(stack);
104 ao_scheme_stack_push(void)
106 struct ao_scheme_stack *stack;
108 stack = ao_scheme_stack_new();
113 stack->prev = ao_scheme_stack_poly(ao_scheme_stack);
114 stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current);
115 stack->list = AO_SCHEME_NIL;
117 ao_scheme_stack = stack;
119 DBGI("stack push\n");
126 ao_scheme_stack_pop(void)
129 struct ao_scheme_frame *prev_frame;
131 if (!ao_scheme_stack)
133 prev = ao_scheme_stack->prev;
134 if (!ao_scheme_stack_marked(ao_scheme_stack)) {
135 ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list);
136 ao_scheme_stack_free_list = ao_scheme_stack;
139 ao_scheme_stack = ao_scheme_poly_stack(prev);
140 prev_frame = ao_scheme_frame_current;
142 ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
144 ao_scheme_frame_current = NULL;
145 if (ao_scheme_frame_current != prev_frame)
146 ao_scheme_frame_free(prev_frame);
153 ao_scheme_stack_clear(void)
155 ao_scheme_stack = NULL;
156 ao_scheme_frame_current = NULL;
157 ao_scheme_v = AO_SCHEME_NIL;
161 ao_scheme_stack_write(ao_poly poly)
163 struct ao_scheme_stack *s = ao_scheme_poly_stack(poly);
166 if (s->type & AO_SCHEME_STACK_PRINT) {
167 printf("[recurse...]");
170 s->type |= AO_SCHEME_STACK_PRINT;
172 printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n");
173 printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]);
174 ao_scheme_error_poly ("values: ", s->values, s->values_tail);
175 ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL);
176 ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame));
178 s->type &= ~AO_SCHEME_STACK_PRINT;
179 s = ao_scheme_poly_stack(s->prev);
184 * Copy a stack, being careful to keep everybody referenced
186 static struct ao_scheme_stack *
187 ao_scheme_stack_copy(struct ao_scheme_stack *old)
189 struct ao_scheme_stack *new = NULL;
190 struct ao_scheme_stack *n, *prev = NULL;
193 ao_scheme_stack_stash(0, old);
194 ao_scheme_stack_stash(1, new);
195 ao_scheme_stack_stash(2, prev);
196 n = ao_scheme_stack_new();
197 prev = ao_scheme_stack_fetch(2);
198 new = ao_scheme_stack_fetch(1);
199 old = ao_scheme_stack_fetch(0);
203 ao_scheme_stack_mark(old);
204 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
208 prev->prev = ao_scheme_stack_poly(n);
213 old = ao_scheme_poly_stack(old->prev);
219 * Evaluate a continuation invocation
222 ao_scheme_stack_eval(void)
224 struct ao_scheme_cons *cons;
225 struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
227 return AO_SCHEME_NIL;
229 cons = ao_scheme_poly_cons(ao_scheme_stack->values);
231 if (!cons || !cons->cdr)
232 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
234 new->state = eval_val;
236 ao_scheme_stack = new;
237 ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
239 return ao_scheme_poly_cons(cons->cdr)->car;
243 * Call with current continuation. This calls a lambda, passing
244 * it a single argument which is the current continuation
247 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
249 struct ao_scheme_stack *new;
252 /* Make sure the single parameter is a lambda */
253 if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1))
254 return AO_SCHEME_NIL;
255 if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0))
256 return AO_SCHEME_NIL;
258 /* go get the lambda */
259 ao_scheme_v = ao_scheme_arg(cons, 0);
261 /* Note that the whole call chain now has
262 * a reference to it which may escape
264 new = ao_scheme_stack_copy(ao_scheme_stack);
266 return AO_SCHEME_NIL;
268 /* re-fetch cons after the allocation */
269 cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
271 /* Reset the arg list to the current stack,
272 * and call the lambda
275 cons->car = ao_scheme_stack_poly(new);
276 cons->cdr = AO_SCHEME_NIL;
277 v = ao_scheme_lambda_eval();
278 ao_scheme_stack->sexprs = v;
279 ao_scheme_stack->state = eval_begin;
280 return AO_SCHEME_NIL;