git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_stack.c

   1 /*
   2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
   3  *
   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.
   8  *
   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.
  13  */
  14
  15 #include "ao_scheme.h"
  16
  17 const struct ao_scheme_type ao_scheme_stack_type;
  18
  19 static int
  20 stack_size(void *addr)
  21 {
  22         (void) addr;
  23         return sizeof (struct ao_scheme_stack);
  24 }
  25
  26 static void
  27 stack_mark(void *addr)
  28 {
  29         struct ao_scheme_stack  *stack = addr;
  30         for (;;) {
  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))
  38                         break;
  39         }
  40 }
  41
  42 static void
  43 stack_move(void *addr)
  44 {
  45         struct ao_scheme_stack  *stack = addr;
  46
  47         while (stack) {
  48                 struct ao_scheme_stack  *prev;
  49                 int                     ret;
  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);
  56                 if (!prev)
  57                         break;
  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);
  61                 if (ret)
  62                         break;
  63                 stack = prev;
  64         }
  65 }
  66
  67 const struct ao_scheme_type ao_scheme_stack_type = {
  68         .size = stack_size,
  69         .mark = stack_mark,
  70         .move = stack_move,
  71         .name = "stack"
  72 };
  73
  74 struct ao_scheme_stack          *ao_scheme_stack_free_list;
  75
  76 void
  77 ao_scheme_stack_reset(struct ao_scheme_stack *stack)
  78 {
  79         stack->state = eval_sexpr;
  80         stack->sexprs = AO_SCHEME_NIL;
  81         stack->values = AO_SCHEME_NIL;
  82         stack->values_tail = AO_SCHEME_NIL;
  83 }
  84
  85 static struct ao_scheme_stack *
  86 ao_scheme_stack_new(void)
  87 {
  88         struct ao_scheme_stack *stack;
  89
  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);
  93         } else {
  94                 stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack));
  95                 if (!stack)
  96                         return 0;
  97                 stack->type = AO_SCHEME_STACK;
  98         }
  99         ao_scheme_stack_reset(stack);
 100         return stack;
 101 }
 102
 103 int
 104 ao_scheme_stack_push(void)
 105 {
 106         struct ao_scheme_stack  *stack;
 107
 108         stack = ao_scheme_stack_new();
 109
 110         if (!stack)
 111                 return 0;
 112
 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;
 116
 117         ao_scheme_stack = stack;
 118
 119         DBGI("stack push\n");
 120         DBG_FRAMES();
 121         DBG_IN();
 122         return 1;
 123 }
 124
 125 void
 126 ao_scheme_stack_pop(void)
 127 {
 128         ao_poly                 prev;
 129         struct ao_scheme_frame  *prev_frame;
 130
 131         if (!ao_scheme_stack)
 132                 return;
 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;
 137         }
 138
 139         ao_scheme_stack = ao_scheme_poly_stack(prev);
 140         prev_frame = ao_scheme_frame_current;
 141         if (ao_scheme_stack)
 142                 ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
 143         else
 144                 ao_scheme_frame_current = NULL;
 145         if (ao_scheme_frame_current != prev_frame)
 146                 ao_scheme_frame_free(prev_frame);
 147         DBG_OUT();
 148         DBGI("stack pop\n");
 149         DBG_FRAMES();
 150 }
 151
 152 void
 153 ao_scheme_stack_clear(void)
 154 {
 155         ao_scheme_stack = NULL;
 156         ao_scheme_frame_current = NULL;
 157         ao_scheme_v = AO_SCHEME_NIL;
 158 }
 159
 160 void
 161 ao_scheme_stack_write(ao_poly poly, bool write)
 162 {
 163         struct ao_scheme_stack  *s = ao_scheme_poly_stack(poly);
 164         struct ao_scheme_stack  *clear = s;
 165         int                     written = 0;
 166
 167         (void) write;
 168         ao_scheme_print_start();
 169         ao_scheme_frame_print_indent += 2;
 170         while (s) {
 171                 if (ao_scheme_print_mark_addr(s)) {
 172                         printf("[recurse...]");
 173                         break;
 174                 }
 175                 written++;
 176                 printf("\t[\n");
 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);
 180                 printf("\t]\n");
 181                 s = ao_scheme_poly_stack(s->prev);
 182         }
 183         ao_scheme_frame_print_indent -= 2;
 184         if (ao_scheme_print_stop()) {
 185                 while (written--) {
 186                         ao_scheme_print_clear_addr(clear);
 187                         clear = ao_scheme_poly_stack(clear->prev);
 188                 }
 189         }
 190 }
 191
 192 /*
 193  * Copy a stack, being careful to keep everybody referenced
 194  */
 195 static struct ao_scheme_stack *
 196 ao_scheme_stack_copy(struct ao_scheme_stack *old)
 197 {
 198         struct ao_scheme_stack *new = NULL;
 199         struct ao_scheme_stack *n, *prev = NULL;
 200
 201         while (old) {
 202                 ao_scheme_stack_stash(0, old);
 203                 ao_scheme_stack_stash(1, new);
 204                 ao_scheme_stack_stash(2, prev);
 205                 n = ao_scheme_stack_new();
 206                 prev = ao_scheme_stack_fetch(2);
 207                 new = ao_scheme_stack_fetch(1);
 208                 old = ao_scheme_stack_fetch(0);
 209                 if (!n)
 210                         return NULL;
 211
 212                 ao_scheme_stack_mark(old);
 213                 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
 214                 *n = *old;
 215
 216                 if (prev)
 217                         prev->prev = ao_scheme_stack_poly(n);
 218                 else
 219                         new = n;
 220                 prev = n;
 221
 222                 old = ao_scheme_poly_stack(old->prev);
 223         }
 224         return new;
 225 }
 226
 227 /*
 228  * Evaluate a continuation invocation
 229  */
 230 ao_poly
 231 ao_scheme_stack_eval(void)
 232 {
 233         struct ao_scheme_cons   *cons;
 234         struct ao_scheme_stack  *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
 235         if (!new)
 236                 return AO_SCHEME_NIL;
 237
 238         cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 239
 240         if (!cons || !cons->cdr)
 241                 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
 242
 243         new->state = eval_val;
 244
 245         ao_scheme_stack = new;
 246         ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
 247
 248         return ao_scheme_poly_cons(cons->cdr)->car;
 249 }
 250
 251 /*
 252  * Call with current continuation. This calls a lambda, passing
 253  * it a single argument which is the current continuation
 254  */
 255 ao_poly
 256 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
 257 {
 258         struct ao_scheme_stack  *new;
 259         ao_poly                 v;
 260
 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;
 266
 267         /* go get the lambda */
 268         ao_scheme_v = ao_scheme_arg(cons, 0);
 269
 270         /* Note that the whole call chain now has
 271          * a reference to it which may escape
 272          */
 273         new = ao_scheme_stack_copy(ao_scheme_stack);
 274         if (!new)
 275                 return AO_SCHEME_NIL;
 276
 277         /* re-fetch cons after the allocation */
 278         cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
 279
 280         /* Reset the arg list to the current stack,
 281          * and call the lambda
 282          */
 283
 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;
 290 }