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, bool write)
163 struct ao_scheme_stack *s = ao_scheme_poly_stack(poly);
164 struct ao_scheme_stack *clear = s;
168 ao_scheme_print_start();
169 ao_scheme_frame_print_indent += 2;
171 if (ao_scheme_print_mark_addr(s)) {
172 printf("[recurse...]");
177 ao_scheme_printf("\t\texpr: %v\n", s->list);
178 ao_scheme_printf("\t\tvalues: %v\n", s->values);
179 ao_scheme_printf("\t\tframe: %v\n", s->frame);
181 s = ao_scheme_poly_stack(s->prev);
183 ao_scheme_frame_print_indent -= 2;
184 if (ao_scheme_print_stop()) {
186 ao_scheme_print_clear_addr(clear);
187 clear = ao_scheme_poly_stack(clear->prev);
193 * Copy a stack, being careful to keep everybody referenced
195 static struct ao_scheme_stack *
196 ao_scheme_stack_copy(struct ao_scheme_stack *old)
198 struct ao_scheme_stack *new = NULL;
199 struct ao_scheme_stack *n, *prev = NULL;
202 ao_scheme_stack_stash(old);
203 ao_scheme_stack_stash(new);
204 ao_scheme_stack_stash(prev);
205 n = ao_scheme_stack_new();
206 prev = ao_scheme_stack_fetch();
207 new = ao_scheme_stack_fetch();
208 old = ao_scheme_stack_fetch();
212 ao_scheme_stack_mark(old);
213 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
217 prev->prev = ao_scheme_stack_poly(n);
222 old = ao_scheme_poly_stack(old->prev);
228 * Evaluate a continuation invocation
231 ao_scheme_stack_eval(void)
233 struct ao_scheme_cons *cons;
234 struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
236 return AO_SCHEME_NIL;
238 cons = ao_scheme_poly_cons(ao_scheme_stack->values);
240 if (!cons || !cons->cdr)
241 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
243 new->state = eval_val;
245 ao_scheme_stack = new;
246 ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
248 return ao_scheme_poly_cons(cons->cdr)->car;
252 * Call with current continuation. This calls a lambda, passing
253 * it a single argument which is the current continuation
256 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
258 struct ao_scheme_stack *new;
261 /* Make sure the single parameter is a lambda */
262 if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1))
263 return AO_SCHEME_NIL;
264 if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0))
265 return AO_SCHEME_NIL;
267 /* go get the lambda */
268 ao_scheme_v = ao_scheme_arg(cons, 0);
270 /* Note that the whole call chain now has
271 * a reference to it which may escape
273 new = ao_scheme_stack_copy(ao_scheme_stack);
275 return AO_SCHEME_NIL;
277 /* re-fetch cons after the allocation */
278 cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
280 /* Reset the arg list to the current stack,
281 * and call the lambda
284 cons->car = ao_scheme_stack_poly(new);
285 cons->cdr = AO_SCHEME_NIL;
286 v = ao_scheme_lambda_eval();
287 ao_scheme_stack->sexprs = v;
288 ao_scheme_stack->state = eval_begin;
289 return AO_SCHEME_NIL;