git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_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 #define DBG_EVAL 0
  16 #include "ao_lisp.h"
  17
  18 const struct ao_lisp_type ao_lisp_stack_type;
  19
  20 static int
  21 stack_size(void *addr)
  22 {
  23         (void) addr;
  24         return sizeof (struct ao_lisp_stack);
  25 }
  26
  27 static void
  28 stack_mark(void *addr)
  29 {
  30         struct ao_lisp_stack    *stack = addr;
  31         for (;;) {
  32                 ao_lisp_poly_mark(stack->sexprs, 0);
  33                 ao_lisp_poly_mark(stack->values, 0);
  34                 /* no need to mark values_tail */
  35                 ao_lisp_poly_mark(stack->frame, 0);
  36                 ao_lisp_poly_mark(stack->list, 0);
  37                 stack = ao_lisp_poly_stack(stack->prev);
  38                 if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
  39                         break;
  40         }
  41 }
  42
  43 static void
  44 stack_move(void *addr)
  45 {
  46         struct ao_lisp_stack    *stack = addr;
  47
  48         while (stack) {
  49                 struct ao_lisp_stack    *prev;
  50                 int                     ret;
  51                 (void) ao_lisp_poly_move(&stack->sexprs, 0);
  52                 (void) ao_lisp_poly_move(&stack->values, 0);
  53                 (void) ao_lisp_poly_move(&stack->values_tail, 0);
  54                 (void) ao_lisp_poly_move(&stack->frame, 0);
  55                 (void) ao_lisp_poly_move(&stack->list, 0);
  56                 prev = ao_lisp_poly_stack(stack->prev);
  57                 if (!prev)
  58                         break;
  59                 ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
  60                 if (prev != ao_lisp_poly_stack(stack->prev))
  61                         stack->prev = ao_lisp_stack_poly(prev);
  62                 if (ret)
  63                         break;
  64                 stack = prev;
  65         }
  66 }
  67
  68 const struct ao_lisp_type ao_lisp_stack_type = {
  69         .size = stack_size,
  70         .mark = stack_mark,
  71         .move = stack_move,
  72         .name = "stack"
  73 };
  74
  75 struct ao_lisp_stack            *ao_lisp_stack_free_list;
  76
  77 void
  78 ao_lisp_stack_reset(struct ao_lisp_stack *stack)
  79 {
  80         stack->state = eval_sexpr;
  81         stack->sexprs = AO_LISP_NIL;
  82         stack->values = AO_LISP_NIL;
  83         stack->values_tail = AO_LISP_NIL;
  84 }
  85
  86 static struct ao_lisp_stack *
  87 ao_lisp_stack_new(void)
  88 {
  89         struct ao_lisp_stack *stack;
  90
  91         if (ao_lisp_stack_free_list) {
  92                 stack = ao_lisp_stack_free_list;
  93                 ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
  94         } else {
  95                 stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
  96                 if (!stack)
  97                         return 0;
  98                 stack->type = AO_LISP_STACK;
  99         }
 100         ao_lisp_stack_reset(stack);
 101         return stack;
 102 }
 103
 104 int
 105 ao_lisp_stack_push(void)
 106 {
 107         struct ao_lisp_stack    *stack = ao_lisp_stack_new();
 108
 109         if (!stack)
 110                 return 0;
 111
 112         stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
 113         stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
 114         stack->list = AO_LISP_NIL;
 115
 116         ao_lisp_stack = stack;
 117
 118         DBGI("stack push\n");
 119         DBG_FRAMES();
 120         DBG_IN();
 121         return 1;
 122 }
 123
 124 void
 125 ao_lisp_stack_pop(void)
 126 {
 127         ao_poly                 prev;
 128         struct ao_lisp_frame    *prev_frame;
 129
 130         if (!ao_lisp_stack)
 131                 return;
 132         prev = ao_lisp_stack->prev;
 133         if (!ao_lisp_stack_marked(ao_lisp_stack)) {
 134                 ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
 135                 ao_lisp_stack_free_list = ao_lisp_stack;
 136         }
 137
 138         ao_lisp_stack = ao_lisp_poly_stack(prev);
 139         prev_frame = ao_lisp_frame_current;
 140         if (ao_lisp_stack)
 141                 ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
 142         else
 143                 ao_lisp_frame_current = NULL;
 144         if (ao_lisp_frame_current != prev_frame)
 145                 ao_lisp_frame_free(prev_frame);
 146         DBG_OUT();
 147         DBGI("stack pop\n");
 148         DBG_FRAMES();
 149 }
 150
 151 void
 152 ao_lisp_stack_clear(void)
 153 {
 154         ao_lisp_stack = NULL;
 155         ao_lisp_frame_current = NULL;
 156         ao_lisp_v = AO_LISP_NIL;
 157 }
 158
 159 void
 160 ao_lisp_stack_print(ao_poly poly)
 161 {
 162         struct ao_lisp_stack *s = ao_lisp_poly_stack(poly);
 163
 164         if (s->type & AO_LISP_STACK_PRINT) {
 165                 printf("[recurse...]");
 166                 return;
 167         }
 168         while (s) {
 169                 s->type |= AO_LISP_STACK_PRINT;
 170                 printf("\t[\n");
 171                 printf("\t\texpr:   "); ao_lisp_poly_print(s->list); printf("\n");
 172                 printf("\t\tstate:  %s\n", ao_lisp_state_names[s->state]);
 173                 ao_lisp_error_poly ("values: ", s->values, s->values_tail);
 174                 ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL);
 175                 ao_lisp_error_frame(2, "frame:  ", ao_lisp_poly_frame(s->frame));
 176                 printf("\t]\n");
 177                 s->type &= ~AO_LISP_STACK_PRINT;
 178                 s = ao_lisp_poly_stack(s->prev);
 179         }
 180 }
 181
 182 /*
 183  * Copy a stack, being careful to keep everybody referenced
 184  */
 185 static struct ao_lisp_stack *
 186 ao_lisp_stack_copy(struct ao_lisp_stack *old)
 187 {
 188         struct ao_lisp_stack *new = NULL;
 189         struct ao_lisp_stack *n, *prev = NULL;
 190
 191         while (old) {
 192                 ao_lisp_stack_stash(0, old);
 193                 ao_lisp_stack_stash(1, new);
 194                 ao_lisp_stack_stash(2, prev);
 195                 n = ao_lisp_stack_new();
 196                 prev = ao_lisp_stack_fetch(2);
 197                 new = ao_lisp_stack_fetch(1);
 198                 old = ao_lisp_stack_fetch(0);
 199                 if (!n)
 200                         return NULL;
 201
 202                 ao_lisp_stack_mark(old);
 203                 ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame));
 204                 *n = *old;
 205
 206                 if (prev)
 207                         prev->prev = ao_lisp_stack_poly(n);
 208                 else
 209                         new = n;
 210                 prev = n;
 211
 212                 old = ao_lisp_poly_stack(old->prev);
 213         }
 214         return new;
 215 }
 216
 217 /*
 218  * Evaluate a continuation invocation
 219  */
 220 ao_poly
 221 ao_lisp_stack_eval(void)
 222 {
 223         struct ao_lisp_stack    *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v));
 224         if (!new)
 225                 return AO_LISP_NIL;
 226
 227         struct ao_lisp_cons     *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
 228
 229         if (!cons || !cons->cdr)
 230                 return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value");
 231
 232         new->state = eval_val;
 233
 234         ao_lisp_stack = new;
 235         ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
 236
 237         return ao_lisp_poly_cons(cons->cdr)->car;
 238 }
 239
 240 /*
 241  * Call with current continuation. This calls a lambda, passing
 242  * it a single argument which is the current continuation
 243  */
 244 ao_poly
 245 ao_lisp_call_cc(struct ao_lisp_cons *cons)
 246 {
 247         struct ao_lisp_stack    *new;
 248         ao_poly                 v;
 249
 250         /* Make sure the single parameter is a lambda */
 251         if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1))
 252                 return AO_LISP_NIL;
 253         if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0))
 254                 return AO_LISP_NIL;
 255
 256         /* go get the lambda */
 257         ao_lisp_v = ao_lisp_arg(cons, 0);
 258
 259         /* Note that the whole call chain now has
 260          * a reference to it which may escape
 261          */
 262         new = ao_lisp_stack_copy(ao_lisp_stack);
 263         if (!new)
 264                 return AO_LISP_NIL;
 265
 266         /* re-fetch cons after the allocation */
 267         cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr);
 268
 269         /* Reset the arg list to the current stack,
 270          * and call the lambda
 271          */
 272
 273         cons->car = ao_lisp_stack_poly(new);
 274         cons->cdr = AO_LISP_NIL;
 275         v = ao_lisp_lambda_eval();
 276         ao_lisp_stack->sexprs = v;
 277         ao_lisp_stack->state = eval_progn;
 278         return AO_LISP_NIL;
 279 }