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