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)
 162 {
 163         struct ao_scheme_stack *s = ao_scheme_poly_stack(poly);
 164
 165         while (s) {
 166                 if (s->type & AO_SCHEME_STACK_PRINT) {
 167                         printf("[recurse...]");
 168                         return;
 169                 }
 170                 s->type |= AO_SCHEME_STACK_PRINT;
 171                 printf("\t[\n");
 172                 printf("\t\texpr:   "); ao_scheme_poly_write(s->list); printf("\n");
 173                 printf("\t\tstate:  %s\n", ao_scheme_state_names[s->state]);
 174                 ao_scheme_error_poly ("values: ", s->values, s->values_tail);
 175                 ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL);
 176                 ao_scheme_error_frame(2, "frame:  ", ao_scheme_poly_frame(s->frame));
 177                 printf("\t]\n");
 178                 s->type &= ~AO_SCHEME_STACK_PRINT;
 179                 s = ao_scheme_poly_stack(s->prev);
 180         }
 181 }
 182
 183 /*
 184  * Copy a stack, being careful to keep everybody referenced
 185  */
 186 static struct ao_scheme_stack *
 187 ao_scheme_stack_copy(struct ao_scheme_stack *old)
 188 {
 189         struct ao_scheme_stack *new = NULL;
 190         struct ao_scheme_stack *n, *prev = NULL;
 191
 192         while (old) {
 193                 ao_scheme_stack_stash(0, old);
 194                 ao_scheme_stack_stash(1, new);
 195                 ao_scheme_stack_stash(2, prev);
 196                 n = ao_scheme_stack_new();
 197                 prev = ao_scheme_stack_fetch(2);
 198                 new = ao_scheme_stack_fetch(1);
 199                 old = ao_scheme_stack_fetch(0);
 200                 if (!n)
 201                         return NULL;
 202
 203                 ao_scheme_stack_mark(old);
 204                 ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame));
 205                 *n = *old;
 206
 207                 if (prev)
 208                         prev->prev = ao_scheme_stack_poly(n);
 209                 else
 210                         new = n;
 211                 prev = n;
 212
 213                 old = ao_scheme_poly_stack(old->prev);
 214         }
 215         return new;
 216 }
 217
 218 /*
 219  * Evaluate a continuation invocation
 220  */
 221 ao_poly
 222 ao_scheme_stack_eval(void)
 223 {
 224         struct ao_scheme_stack  *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v));
 225         if (!new)
 226                 return AO_SCHEME_NIL;
 227
 228         struct ao_scheme_cons   *cons = ao_scheme_poly_cons(ao_scheme_stack->values);
 229
 230         if (!cons || !cons->cdr)
 231                 return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value");
 232
 233         new->state = eval_val;
 234
 235         ao_scheme_stack = new;
 236         ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame);
 237
 238         return ao_scheme_poly_cons(cons->cdr)->car;
 239 }
 240
 241 /*
 242  * Call with current continuation. This calls a lambda, passing
 243  * it a single argument which is the current continuation
 244  */
 245 ao_poly
 246 ao_scheme_do_call_cc(struct ao_scheme_cons *cons)
 247 {
 248         struct ao_scheme_stack  *new;
 249         ao_poly                 v;
 250
 251         /* Make sure the single parameter is a lambda */
 252         if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1))
 253                 return AO_SCHEME_NIL;
 254         if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0))
 255                 return AO_SCHEME_NIL;
 256
 257         /* go get the lambda */
 258         ao_scheme_v = ao_scheme_arg(cons, 0);
 259
 260         /* Note that the whole call chain now has
 261          * a reference to it which may escape
 262          */
 263         new = ao_scheme_stack_copy(ao_scheme_stack);
 264         if (!new)
 265                 return AO_SCHEME_NIL;
 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         v = ao_scheme_lambda_eval();
 277         ao_scheme_stack->sexprs = v;
 278         ao_scheme_stack->state = eval_begin;
 279         return AO_SCHEME_NIL;
 280 }