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, 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))
  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, 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);
  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_write(FILE *out, ao_poly poly, bool write)
 154 {
 155         struct ao_scheme_stack  *s = ao_scheme_poly_stack(poly);
 156         struct ao_scheme_stack  *clear = s;
 157         int                     written = 0;
 158
 159         (void) write;
 160         ao_scheme_print_start();
 161         ao_scheme_frame_print_indent += 2;
 162         while (s) {
 163                 if (ao_scheme_print_mark_addr(s)) {
 164                         fputs("[recurse...]", out);
 165                         break;
 166                 }
 167                 written++;
 168                 fputs("\t[\n", 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);
 172                 fputs("\t]\n", out);
 173                 s = ao_scheme_poly_stack(s->prev);
 174         }
 175         ao_scheme_frame_print_indent -= 2;
 176         if (ao_scheme_print_stop()) {
 177                 while (written--) {
 178                         ao_scheme_print_clear_addr(clear);
 179                         clear = ao_scheme_poly_stack(clear->prev);
 180                 }
 181         }
 182 }
 183
 184 /*
 185  * Copy a stack, being careful to keep everybody referenced
 186  */
 187 static struct ao_scheme_stack *
 188 ao_scheme_stack_copy(struct ao_scheme_stack *old)
 189 {
 190         struct ao_scheme_stack *new = NULL;
 191         struct ao_scheme_stack *n, *prev = NULL;
 192
 193         while (old) {
 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();
 201                 if (!n)
 202                         return NULL;
 203
 204                 ao_scheme_stack_mark(old);
 205                 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
 206                 *n = *old;
 207
 208                 if (prev)
 209                         prev->prev = ao_scheme_stack_poly(n);
 210                 else
 211                         new = n;
 212                 prev = n;
 213
 214                 old = ao_scheme_poly_stack(old->prev);
 215         }
 216         return new;
 217 }
 218
 219 /*
 220  * Evaluate a continuation invocation
 221  */
 222 ao_poly
 223 ao_scheme_stack_eval(void)
 224 {
 225         struct ao_scheme_cons   *cons;
 226         struct ao_scheme_stack  *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
 227         if (!new)
 228                 return AO_SCHEME_NIL;
 229
 230         cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 231
 232         if (!cons || !cons->cdr)
 233                 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
 234
 235         new->state = eval_val;
 236
 237         ao_scheme_stack = new;
 238         ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
 239
 240         return ao_scheme_poly_cons(cons->cdr)->car;
 241 }
 242
 243 /*
 244  * Call with current continuation. This calls a lambda, passing
 245  * it a single argument which is the current continuation
 246  */
 247 ao_poly
 248 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
 249 {
 250         struct ao_scheme_stack  *new;
 251         ao_poly                 v;
 252
 253         if (!ao_scheme_parse_args(_ao_scheme_atom_call2fcc, cons,
 254                                   AO_SCHEME_LAMBDA|AO_SCHEME_ARG_RET_POLY, &v,
 255                                   AO_SCHEME_ARG_END))
 256                 return AO_SCHEME_NIL;
 257
 258         ao_scheme_poly_stash(v);
 259         /* Note that the whole call chain now has
 260          * a reference to it which may escape
 261          */
 262         new = ao_scheme_stack_copy(ao_scheme_stack);
 263         if (!new)
 264                 return AO_SCHEME_NIL;
 265         v = ao_scheme_poly_fetch();
 266
 267         /* re-fetch cons after the allocation */
 268         cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr);
 269
 270         /* Reset the arg list to the current stack,
 271          * and call the lambda
 272          */
 273
 274         cons->car = ao_scheme_stack_poly(new);
 275         cons->cdr = AO_SCHEME_NIL;
 276
 277         ao_scheme_stack->state = eval_exec;
 278         return v;
 279 }