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.
17 const struct ao_lisp_type ao_lisp_stack_type;
20 stack_size(void *addr)
23 return sizeof (struct ao_lisp_stack);
27 stack_mark(void *addr)
29 struct ao_lisp_stack *stack = addr;
31 ao_lisp_poly_mark(stack->sexprs, 0);
32 ao_lisp_poly_mark(stack->values, 0);
33 /* no need to mark values_tail */
34 ao_lisp_poly_mark(stack->frame, 0);
35 ao_lisp_poly_mark(stack->list, 0);
36 stack = ao_lisp_poly_stack(stack->prev);
37 if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
43 stack_move(void *addr)
45 struct ao_lisp_stack *stack = addr;
48 struct ao_lisp_stack *prev;
50 (void) ao_lisp_poly_move(&stack->sexprs, 0);
51 (void) ao_lisp_poly_move(&stack->values, 0);
52 (void) ao_lisp_poly_move(&stack->values_tail, 0);
53 (void) ao_lisp_poly_move(&stack->frame, 0);
54 (void) ao_lisp_poly_move(&stack->list, 0);
55 prev = ao_lisp_poly_stack(stack->prev);
58 ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
59 if (prev != ao_lisp_poly_stack(stack->prev))
60 stack->prev = ao_lisp_stack_poly(prev);
67 const struct ao_lisp_type ao_lisp_stack_type = {
74 struct ao_lisp_stack *ao_lisp_stack_free_list;
77 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
79 stack->state = eval_sexpr;
80 stack->sexprs = AO_LISP_NIL;
81 stack->values = AO_LISP_NIL;
82 stack->values_tail = AO_LISP_NIL;
85 static struct ao_lisp_stack *
86 ao_lisp_stack_new(void)
88 struct ao_lisp_stack *stack;
90 if (ao_lisp_stack_free_list) {
91 stack = ao_lisp_stack_free_list;
92 ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
94 stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
97 stack->type = AO_LISP_STACK;
99 ao_lisp_stack_reset(stack);
104 ao_lisp_stack_push(void)
106 struct ao_lisp_stack *stack = ao_lisp_stack_new();
111 stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
112 stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
113 stack->list = AO_LISP_NIL;
115 ao_lisp_stack = stack;
117 DBGI("stack push\n");
124 ao_lisp_stack_pop(void)
127 struct ao_lisp_frame *prev_frame;
131 prev = ao_lisp_stack->prev;
132 if (!ao_lisp_stack_marked(ao_lisp_stack)) {
133 ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
134 ao_lisp_stack_free_list = ao_lisp_stack;
137 ao_lisp_stack = ao_lisp_poly_stack(prev);
138 prev_frame = ao_lisp_frame_current;
140 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
142 ao_lisp_frame_current = NULL;
143 if (ao_lisp_frame_current != prev_frame)
144 ao_lisp_frame_free(prev_frame);
151 ao_lisp_stack_clear(void)
153 ao_lisp_stack = NULL;
154 ao_lisp_frame_current = NULL;
155 ao_lisp_v = AO_LISP_NIL;
159 ao_lisp_stack_print(ao_poly poly)
161 struct ao_lisp_stack *s = ao_lisp_poly_stack(poly);
164 if (s->type & AO_LISP_STACK_PRINT) {
165 printf("[recurse...]");
168 s->type |= AO_LISP_STACK_PRINT;
170 printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n");
171 printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]);
172 ao_lisp_error_poly ("values: ", s->values, s->values_tail);
173 ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL);
174 ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame));
176 s->type &= ~AO_LISP_STACK_PRINT;
177 s = ao_lisp_poly_stack(s->prev);
182 * Copy a stack, being careful to keep everybody referenced
184 static struct ao_lisp_stack *
185 ao_lisp_stack_copy(struct ao_lisp_stack *old)
187 struct ao_lisp_stack *new = NULL;
188 struct ao_lisp_stack *n, *prev = NULL;
191 ao_lisp_stack_stash(0, old);
192 ao_lisp_stack_stash(1, new);
193 ao_lisp_stack_stash(2, prev);
194 n = ao_lisp_stack_new();
195 prev = ao_lisp_stack_fetch(2);
196 new = ao_lisp_stack_fetch(1);
197 old = ao_lisp_stack_fetch(0);
201 ao_lisp_stack_mark(old);
202 ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame));
206 prev->prev = ao_lisp_stack_poly(n);
211 old = ao_lisp_poly_stack(old->prev);
217 * Evaluate a continuation invocation
220 ao_lisp_stack_eval(void)
222 struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v));
226 struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
228 if (!cons || !cons->cdr)
229 return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value");
231 new->state = eval_val;
234 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
236 return ao_lisp_poly_cons(cons->cdr)->car;
240 * Call with current continuation. This calls a lambda, passing
241 * it a single argument which is the current continuation
244 ao_lisp_call_cc(struct ao_lisp_cons *cons)
246 struct ao_lisp_stack *new;
249 /* Make sure the single parameter is a lambda */
250 if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1))
252 if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0))
255 /* go get the lambda */
256 ao_lisp_v = ao_lisp_arg(cons, 0);
258 /* Note that the whole call chain now has
259 * a reference to it which may escape
261 new = ao_lisp_stack_copy(ao_lisp_stack);
265 /* re-fetch cons after the allocation */
266 cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr);
268 /* Reset the arg list to the current stack,
269 * and call the lambda
272 cons->car = ao_lisp_stack_poly(new);
273 cons->cdr = AO_LISP_NIL;
274 v = ao_lisp_lambda_eval();
275 ao_lisp_stack->sexprs = v;
276 ao_lisp_stack->state = eval_progn;