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, 1);
32 ao_scheme_poly_mark(stack->values, 1);
33 /* no need to mark values_tail */
34 ao_scheme_poly_mark(stack->frame, 0);
35 ao_scheme_poly_mark(stack->list, 1);
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, 1);
51 (void) ao_scheme_poly_move(&stack->values, 1);
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, 1);
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_write(FILE *out, ao_poly poly, bool write)
155 struct ao_scheme_stack *s = ao_scheme_poly_stack(poly);
156 struct ao_scheme_stack *clear = s;
160 ao_scheme_print_start();
161 ao_scheme_frame_print_indent += 2;
163 if (ao_scheme_print_mark_addr(s)) {
164 fputs("[recurse...]", out);
169 ao_scheme_fprintf(out, "\t\texpr: %v\n", s->list);
170 ao_scheme_fprintf(out, "\t\tvalues: %v\n", s->values);
171 ao_scheme_fprintf(out, "\t\tframe: %v\n", s->frame);
173 s = ao_scheme_poly_stack(s->prev);
175 ao_scheme_frame_print_indent -= 2;
176 if (ao_scheme_print_stop()) {
178 ao_scheme_print_clear_addr(clear);
179 clear = ao_scheme_poly_stack(clear->prev);
185 * Copy a stack, being careful to keep everybody referenced
187 static struct ao_scheme_stack *
188 ao_scheme_stack_copy(struct ao_scheme_stack *old)
190 struct ao_scheme_stack *new = NULL;
191 struct ao_scheme_stack *n, *prev = NULL;
194 ao_scheme_stack_stash(old);
195 ao_scheme_stack_stash(new);
196 ao_scheme_stack_stash(prev);
197 n = ao_scheme_stack_new();
198 prev = ao_scheme_stack_fetch();
199 new = ao_scheme_stack_fetch();
200 old = ao_scheme_stack_fetch();
204 ao_scheme_stack_mark(old);
205 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
209 prev->prev = ao_scheme_stack_poly(n);
214 old = ao_scheme_poly_stack(old->prev);
220 * Evaluate a continuation invocation
223 ao_scheme_stack_eval(void)
225 struct ao_scheme_cons *cons;
226 struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
228 return AO_SCHEME_NIL;
230 cons = ao_scheme_poly_cons(ao_scheme_stack->values);
232 if (!cons || !cons->cdr)
233 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
235 new->state = eval_val;
237 ao_scheme_stack = new;
238 ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
240 return ao_scheme_poly_cons(cons->cdr)->car;
244 * Call with current continuation. This calls a lambda, passing
245 * it a single argument which is the current continuation
248 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
250 struct ao_scheme_stack *new;
253 if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons,
254 AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v,
256 return AO_SCHEME_NIL;
258 ao_scheme_poly_stash(v);
259 /* Note that the whole call chain now has
260 * a reference to it which may escape
262 new = ao_scheme_stack_copy(ao_scheme_stack);
264 return AO_SCHEME_NIL;
265 v = ao_scheme_poly_fetch();
267 /* re-fetch cons after the allocation */
268 cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
270 /* Reset the arg list to the current stack,
271 * and call the lambda
274 cons->car = ao_scheme_stack_poly(new);
275 cons->cdr = AO_SCHEME_NIL;
277 ao_scheme_stack->state = eval_exec;