X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_stack.c;fp=src%2Fscheme%2Fao_scheme_stack.c;h=d19dd6d6d59f1226979041fc278b384c9e77a712;hb=195cbeec19a6a44f309a9040d727d37fe4e2ec97;hp=0000000000000000000000000000000000000000;hpb=9dbc686ad7d3289dc0f9bcf4a973f71100e02ded;p=fw%2Faltos diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +const struct ao_scheme_type ao_scheme_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_scheme_stack *stack = addr; + for (;;) { + ao_scheme_poly_mark(stack->sexprs, 0); + ao_scheme_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_scheme_poly_mark(stack->frame, 0); + ao_scheme_poly_mark(stack->list, 0); + stack = ao_scheme_poly_stack(stack->prev); + if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_scheme_stack *stack = addr; + + while (stack) { + struct ao_scheme_stack *prev; + int ret; + (void) ao_scheme_poly_move(&stack->sexprs, 0); + (void) ao_scheme_poly_move(&stack->values, 0); + (void) ao_scheme_poly_move(&stack->values_tail, 0); + (void) ao_scheme_poly_move(&stack->frame, 0); + (void) ao_scheme_poly_move(&stack->list, 0); + prev = ao_scheme_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); + if (prev != ao_scheme_poly_stack(stack->prev)) + stack->prev = ao_scheme_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_scheme_type ao_scheme_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_scheme_stack *ao_scheme_stack_free_list; + +void +ao_scheme_stack_reset(struct ao_scheme_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_SCHEME_NIL; + stack->values = AO_SCHEME_NIL; + stack->values_tail = AO_SCHEME_NIL; +} + +static struct ao_scheme_stack * +ao_scheme_stack_new(void) +{ + struct ao_scheme_stack *stack; + + if (ao_scheme_stack_free_list) { + stack = ao_scheme_stack_free_list; + ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); + } else { + stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); + if (!stack) + return 0; + stack->type = AO_SCHEME_STACK; + } + ao_scheme_stack_reset(stack); + return stack; +} + +int +ao_scheme_stack_push(void) +{ + struct ao_scheme_stack *stack; + + stack = ao_scheme_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_scheme_stack_poly(ao_scheme_stack); + stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); + stack->list = AO_SCHEME_NIL; + + ao_scheme_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_scheme_stack_pop(void) +{ + ao_poly prev; + struct ao_scheme_frame *prev_frame; + + if (!ao_scheme_stack) + return; + prev = ao_scheme_stack->prev; + if (!ao_scheme_stack_marked(ao_scheme_stack)) { + ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); + ao_scheme_stack_free_list = ao_scheme_stack; + } + + ao_scheme_stack = ao_scheme_poly_stack(prev); + prev_frame = ao_scheme_frame_current; + if (ao_scheme_stack) + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + else + ao_scheme_frame_current = NULL; + if (ao_scheme_frame_current != prev_frame) + ao_scheme_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_scheme_stack_clear(void) +{ + ao_scheme_stack = NULL; + ao_scheme_frame_current = NULL; + ao_scheme_v = AO_SCHEME_NIL; +} + +void +ao_scheme_stack_write(ao_poly poly) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_scheme_stack * +ao_scheme_stack_copy(struct ao_scheme_stack *old) +{ + struct ao_scheme_stack *new = NULL; + struct ao_scheme_stack *n, *prev = NULL; + + while (old) { + ao_scheme_stack_stash(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + if (!n) + return NULL; + + ao_scheme_stack_mark(old); + ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_scheme_stack_poly(n); + else + new = n; + prev = n; + + old = ao_scheme_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_scheme_stack_eval(void) +{ + struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + if (!cons || !cons->cdr) + return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_scheme_stack = new; + ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); + + return ao_scheme_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_scheme_do_call_cc(struct ao_scheme_cons *cons) +{ + struct ao_scheme_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) + return AO_SCHEME_NIL; + + /* go get the lambda */ + ao_scheme_v = ao_scheme_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_scheme_stack_copy(ao_scheme_stack); + if (!new) + return AO_SCHEME_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_scheme_stack_poly(new); + cons->cdr = AO_SCHEME_NIL; + v = ao_scheme_lambda_eval(); + ao_scheme_stack->sexprs = v; + ao_scheme_stack->state = eval_begin; + return AO_SCHEME_NIL; +}