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.
18 const struct ao_lisp_type ao_lisp_stack_type;
21 stack_size(void *addr)
24 return sizeof (struct ao_lisp_stack);
28 stack_mark(void *addr)
30 struct ao_lisp_stack *stack = addr;
32 ao_lisp_poly_mark(stack->sexprs, 0);
33 ao_lisp_poly_mark(stack->values, 0);
34 /* no need to mark values_tail */
35 ao_lisp_poly_mark(stack->frame, 0);
36 ao_lisp_poly_mark(stack->list, 0);
37 stack = ao_lisp_poly_stack(stack->prev);
38 if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
44 stack_move(void *addr)
46 struct ao_lisp_stack *stack = addr;
49 struct ao_lisp_stack *prev;
51 (void) ao_lisp_poly_move(&stack->sexprs, 0);
52 (void) ao_lisp_poly_move(&stack->values, 0);
53 (void) ao_lisp_poly_move(&stack->values_tail, 0);
54 (void) ao_lisp_poly_move(&stack->frame, 0);
55 (void) ao_lisp_poly_move(&stack->list, 0);
56 prev = ao_lisp_poly_stack(stack->prev);
59 ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
60 if (prev != ao_lisp_poly_stack(stack->prev))
61 stack->prev = ao_lisp_stack_poly(prev);
68 const struct ao_lisp_type ao_lisp_stack_type = {
75 struct ao_lisp_stack *ao_lisp_stack_free_list;
78 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
80 stack->state = eval_sexpr;
81 stack->sexprs = AO_LISP_NIL;
82 stack->values = AO_LISP_NIL;
83 stack->values_tail = AO_LISP_NIL;
86 static struct ao_lisp_stack *
87 ao_lisp_stack_new(void)
89 struct ao_lisp_stack *stack;
91 if (ao_lisp_stack_free_list) {
92 stack = ao_lisp_stack_free_list;
93 ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
95 stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
98 stack->type = AO_LISP_STACK;
100 ao_lisp_stack_reset(stack);
105 ao_lisp_stack_push(void)
107 struct ao_lisp_stack *stack = ao_lisp_stack_new();
112 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
113 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
114 stack->list = AO_LISP_NIL;
116 ao_lisp_stack = stack;
118 DBGI("stack push\n");
125 ao_lisp_stack_pop(void)
128 struct ao_lisp_frame *prev_frame;
132 prev = ao_lisp_stack->prev;
133 if (!ao_lisp_stack_marked(ao_lisp_stack)) {
134 ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
135 ao_lisp_stack_free_list = ao_lisp_stack;
138 ao_lisp_stack = ao_lisp_poly_stack(prev);
139 prev_frame = ao_lisp_frame_current;
141 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
143 ao_lisp_frame_current = NULL;
144 if (ao_lisp_frame_current != prev_frame)
145 ao_lisp_frame_free(prev_frame);
152 ao_lisp_stack_clear(void)
154 ao_lisp_stack = NULL;
155 ao_lisp_frame_current = NULL;
156 ao_lisp_v = AO_LISP_NIL;
160 ao_lisp_stack_print(ao_poly poly)
162 struct ao_lisp_stack *s = ao_lisp_poly_stack(poly);
164 if (s->type & AO_LISP_STACK_PRINT) {
165 printf("[recurse...]");
169 s->type |= AO_LISP_STACK_PRINT;
171 printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n");
172 printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]);
173 ao_lisp_error_poly ("values: ", s->values, s->values_tail);
174 ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL);
175 ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame));
177 s->type &= ~AO_LISP_STACK_PRINT;
178 s = ao_lisp_poly_stack(s->prev);
183 * Copy a stack, being careful to keep everybody referenced
185 static struct ao_lisp_stack *
186 ao_lisp_stack_copy(struct ao_lisp_stack *old)
188 struct ao_lisp_stack *new = NULL;
189 struct ao_lisp_stack *n, *prev = NULL;
192 ao_lisp_stack_stash(0, old);
193 ao_lisp_stack_stash(1, new);
194 ao_lisp_stack_stash(2, prev);
195 n = ao_lisp_stack_new();
196 prev = ao_lisp_stack_fetch(2);
197 new = ao_lisp_stack_fetch(1);
198 old = ao_lisp_stack_fetch(0);
202 ao_lisp_stack_mark(old);
203 ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame));
207 prev->prev = ao_lisp_stack_poly(n);
212 old = ao_lisp_poly_stack(old->prev);
218 * Evaluate a continuation invocation
221 ao_lisp_stack_eval(void)
223 struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v));
227 struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
229 if (!cons || !cons->cdr)
230 return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value");
232 new->state = eval_val;
235 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
237 return ao_lisp_poly_cons(cons->cdr)->car;
241 * Call with current continuation. This calls a lambda, passing
242 * it a single argument which is the current continuation
245 ao_lisp_call_cc(struct ao_lisp_cons *cons)
247 struct ao_lisp_stack *new;
250 /* Make sure the single parameter is a lambda */
251 if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1))
253 if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0))
256 /* go get the lambda */
257 ao_lisp_v = ao_lisp_arg(cons, 0);
259 /* Note that the whole call chain now has
260 * a reference to it which may escape
262 new = ao_lisp_stack_copy(ao_lisp_stack);
266 /* re-fetch cons after the allocation */
267 cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr);
269 /* Reset the arg list to the current stack,
270 * and call the lambda
273 cons->car = ao_lisp_stack_poly(new);
274 cons->cdr = AO_LISP_NIL;
275 v = ao_lisp_lambda_eval();
276 ao_lisp_stack->sexprs = v;
277 ao_lisp_stack->state = eval_progn;