This provides call/cc and makes 'stacks' visible to the application.
Signed-off-by: Keith Packard <keithp@keithp.com>
ao_lisp_eval.c \
ao_lisp_rep.c \
ao_lisp_save.c \
+ ao_lisp_stack.c \
ao_lisp_error.c
OBJS=$(SRCS:.c=.o)
#define _ao_lisp_atom_eof _atom("eof")
#define _ao_lisp_atom_save _atom("save")
#define _ao_lisp_atom_restore _atom("restore")
+#define _ao_lisp_atom_call2fcc _atom("call/cc")
#else
#include "ao_lisp_const.h"
#ifndef AO_LISP_POOL
#define AO_LISP_BUILTIN 5
#define AO_LISP_FRAME 6
#define AO_LISP_LAMBDA 7
-#define AO_LISP_NUM_TYPE 8
+#define AO_LISP_STACK 8
+#define AO_LISP_NUM_TYPE 9
+
+/* Leave two bits for types to use as they please */
+#define AO_LISP_OTHER_TYPE_MASK 0x3f
#define AO_LISP_NIL 0
struct ao_lisp_frame {
uint8_t type;
- uint8_t _num;
+ uint8_t num;
ao_poly prev;
struct ao_lisp_val vals[];
};
-#define AO_LISP_FRAME_NUM_MASK 0x7f
-
-/* Set when the frame escapes the lambda */
+/* Set on type when the frame escapes the lambda */
#define AO_LISP_FRAME_MARK 0x80
-
-static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) {
- return f->_num & AO_LISP_FRAME_NUM_MASK;
-}
+#define AO_LISP_FRAME_PRINT 0x40
static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) {
- return f->_num & AO_LISP_FRAME_MARK;
+ return f->type & AO_LISP_FRAME_MARK;
}
static inline struct ao_lisp_frame *
};
struct ao_lisp_stack {
+ uint8_t type; /* AO_LISP_STACK */
uint8_t state; /* enum eval_state */
ao_poly prev; /* previous stack frame */
ao_poly sexprs; /* expressions to evaluate */
ao_poly list; /* most recent function call */
};
+#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */
+#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */
+
+static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) {
+ return s->type & AO_LISP_STACK_MARK;
+}
+
+static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) {
+ s->type |= AO_LISP_STACK_MARK;
+}
+
static inline struct ao_lisp_stack *
ao_lisp_poly_stack(ao_poly p)
{
return ao_lisp_poly(stack, AO_LISP_OTHER);
}
-extern struct ao_lisp_stack *ao_lisp_stack;
-extern struct ao_lisp_stack *ao_lisp_stack_free_list;
extern ao_poly ao_lisp_v;
#define AO_LISP_FUNC_LAMBDA 0
builtin_led,
builtin_save,
builtin_restore,
+ builtin_call_cc,
_builtin_last
};
static inline uint8_t
ao_lisp_other_type(void *other) {
- return *((uint8_t *) other);
+ return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK;
}
static inline ao_poly
char *
ao_lisp_string_fetch(int id);
+void
+ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack);
+
+struct ao_lisp_stack *
+ao_lisp_stack_fetch(int id);
+
void
ao_lisp_poly_stash(int id, ao_poly poly);
/* lambda */
extern const struct ao_lisp_type ao_lisp_lambda_type;
+extern const char *ao_lisp_state_names[];
+
struct ao_lisp_lambda *
ao_lisp_lambda_new(ao_poly cons);
ao_poly
ao_lisp_restore(struct ao_lisp_cons *cons);
-/* error */
+/* stack */
extern const struct ao_lisp_type ao_lisp_stack_type;
+extern struct ao_lisp_stack *ao_lisp_stack;
+extern struct ao_lisp_stack *ao_lisp_stack_free_list;
+
+void
+ao_lisp_stack_reset(struct ao_lisp_stack *stack);
+
+int
+ao_lisp_stack_push(void);
+
+void
+ao_lisp_stack_pop(void);
+
+void
+ao_lisp_stack_clear(void);
+
+void
+ao_lisp_stack_print(ao_poly stack);
+
+ao_poly
+ao_lisp_stack_eval(void);
+
+ao_poly
+ao_lisp_call_cc(struct ao_lisp_cons *cons);
+
+/* error */
+
+void
+ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last);
void
-ao_lisp_stack_print(void);
+ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame);
ao_poly
ao_lisp_error(int error, char *format, ...);
[builtin_led] = _ao_lisp_atom_led,
[builtin_save] = _ao_lisp_atom_save,
[builtin_restore] = _ao_lisp_atom_restore,
+ [builtin_call_cc] = _ao_lisp_atom_call2fcc,
};
ao_lisp_builtin_print(ao_poly b)
{
struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b);
- printf("[builtin %s %s]",
- ao_lisp_args_name(builtin->args),
- ao_lisp_builtin_name(builtin->func));
+ printf("%s", ao_lisp_builtin_name(builtin->func));
}
ao_poly
[builtin_delay] = ao_lisp_delay,
[builtin_save] = ao_lisp_save,
[builtin_restore] = ao_lisp_restore,
+ [builtin_call_cc] = ao_lisp_call_cc,
};
#include "ao_lisp.h"
#include <stdarg.h>
-static void
-ao_lisp_error_poly(char *name, ao_poly poly)
+void
+ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last)
{
int first = 1;
printf("\t\t%s(", name);
if (ao_lisp_poly_type(poly) == AO_LISP_CONS) {
- struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly);
-
- if (cons) {
- while (cons) {
+ if (poly) {
+ while (poly) {
+ struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly);
if (!first)
printf("\t\t ");
else
first = 0;
ao_lisp_poly_print(cons->car);
printf("\n");
- cons = ao_lisp_poly_cons(cons->cdr);
+ if (poly == last)
+ break;
+ poly = cons->cdr;
}
printf("\t\t )\n");
} else
printf("\t");
}
-static void
+void
ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame)
{
int f;
tabs(indent);
printf ("%s{", name);
if (frame) {
- for (f = 0; f < ao_lisp_frame_num(frame); f++) {
- if (f != 0) {
- tabs(indent);
- printf(" ");
+ if (frame->type & AO_LISP_FRAME_PRINT)
+ printf("recurse...");
+ else {
+ frame->type |= AO_LISP_FRAME_PRINT;
+ for (f = 0; f < frame->num; f++) {
+ if (f != 0) {
+ tabs(indent);
+ printf(" ");
+ }
+ ao_lisp_poly_print(frame->vals[f].atom);
+ printf(" = ");
+ ao_lisp_poly_print(frame->vals[f].val);
+ printf("\n");
}
- ao_lisp_poly_print(frame->vals[f].atom);
- printf(" = ");
- ao_lisp_poly_print(frame->vals[f].val);
- printf("\n");
+ if (frame->prev)
+ ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev));
+ frame->type &= ~AO_LISP_FRAME_PRINT;
}
- if (frame->prev)
- ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev));
- }
- tabs(indent);
- printf(" }\n");
+ tabs(indent);
+ printf(" }\n");
+ } else
+ printf ("}\n");
}
-static const char *state_names[] = {
- "sexpr",
- "val",
- "formal",
- "exec",
- "cond",
- "cond_test",
- "progn",
-};
-
-void
-ao_lisp_stack_print(void)
-{
- struct ao_lisp_stack *s;
- printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n");
- printf("Stack:\n");
- for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) {
- printf("\t[\n");
- printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n");
- printf("\t\tstate: %s\n", state_names[s->state]);
-// printf("\t\tmacro: %s\n", s->macro ? "true" : "false");
- ao_lisp_error_poly ("sexprs: ", s->sexprs);
- ao_lisp_error_poly ("values: ", s->values);
- ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame));
-// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame));
- printf("\t]\n");
- }
-}
ao_poly
ao_lisp_error(int error, char *format, ...)
vprintf(format, args);
va_end(args);
printf("\n");
- ao_lisp_stack_print();
+ printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n");
+ printf("Stack:\n");
+ ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack));
printf("Globals:\n\t");
ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global));
printf("\n");
#include "ao_lisp.h"
#include <assert.h>
-const struct ao_lisp_type ao_lisp_stack_type;
-
-static int
-stack_size(void *addr)
-{
- (void) addr;
- return sizeof (struct ao_lisp_stack);
-}
-
-static void
-stack_mark(void *addr)
-{
- struct ao_lisp_stack *stack = addr;
- for (;;) {
- ao_lisp_poly_mark(stack->sexprs, 0);
- ao_lisp_poly_mark(stack->values, 0);
- /* no need to mark values_tail */
- ao_lisp_poly_mark(stack->frame, 0);
- ao_lisp_poly_mark(stack->list, 0);
- stack = ao_lisp_poly_stack(stack->prev);
- if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
- break;
- }
-}
-
-static void
-stack_move(void *addr)
-{
- struct ao_lisp_stack *stack = addr;
-
- while (stack) {
- struct ao_lisp_stack *prev;
- int ret;
- (void) ao_lisp_poly_move(&stack->sexprs, 0);
- (void) ao_lisp_poly_move(&stack->values, 0);
- (void) ao_lisp_poly_move(&stack->values_tail, 0);
- (void) ao_lisp_poly_move(&stack->frame, 0);
- (void) ao_lisp_poly_move(&stack->list, 0);
- prev = ao_lisp_poly_stack(stack->prev);
- if (!prev)
- break;
- ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
- if (prev != ao_lisp_poly_stack(stack->prev))
- stack->prev = ao_lisp_stack_poly(prev);
- if (ret)
- break;
- stack = prev;
- }
-}
-
-const struct ao_lisp_type ao_lisp_stack_type = {
- .size = stack_size,
- .mark = stack_mark,
- .move = stack_move,
- .name = "stack"
-};
-
struct ao_lisp_stack *ao_lisp_stack;
ao_poly ao_lisp_v;
-struct ao_lisp_stack *ao_lisp_stack_free_list;
-
ao_poly
ao_lisp_set_cond(struct ao_lisp_cons *c)
{
return AO_LISP_NIL;
}
-static void
-ao_lisp_stack_reset(struct ao_lisp_stack *stack)
-{
- stack->state = eval_sexpr;
- stack->sexprs = AO_LISP_NIL;
- stack->values = AO_LISP_NIL;
- stack->values_tail = AO_LISP_NIL;
-}
-
-
-static int
-ao_lisp_stack_push(void)
-{
- struct ao_lisp_stack *stack;
- if (ao_lisp_stack_free_list) {
- stack = ao_lisp_stack_free_list;
- ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
- } else {
- stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
- if (!stack)
- return 0;
- }
- stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
- stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
- stack->list = AO_LISP_NIL;
- ao_lisp_stack = stack;
- ao_lisp_stack_reset(stack);
- DBGI("stack push\n");
- DBG_FRAMES();
- DBG_IN();
- return 1;
-}
-
-static void
-ao_lisp_stack_pop(void)
-{
- ao_poly prev;
- struct ao_lisp_frame *prev_frame;
-
- if (!ao_lisp_stack)
- return;
- prev = ao_lisp_stack->prev;
- ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
- ao_lisp_stack_free_list = ao_lisp_stack;
-
- ao_lisp_stack = ao_lisp_poly_stack(prev);
- prev_frame = ao_lisp_frame_current;
- if (ao_lisp_stack)
- ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
- else
- ao_lisp_frame_current = NULL;
- if (ao_lisp_frame_current != prev_frame)
- ao_lisp_frame_free(prev_frame);
- DBG_OUT();
- DBGI("stack pop\n");
- DBG_FRAMES();
-}
-
-static void
-ao_lisp_stack_clear(void)
-{
- ao_lisp_stack = NULL;
- ao_lisp_frame_current = NULL;
- ao_lisp_v = AO_LISP_NIL;
-}
-
static int
func_type(ao_poly func)
{
return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK;
case AO_LISP_LAMBDA:
return ao_lisp_poly_lambda(func)->args;
+ case AO_LISP_STACK:
+ return AO_LISP_FUNC_LAMBDA;
default:
ao_lisp_error(AO_LISP_INVALID, "not a func");
return -1;
DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n");
});
builtin = ao_lisp_poly_builtin(ao_lisp_v);
- if (builtin->args & AO_LISP_FUNC_FREE_ARGS)
+ if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack))
ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values));
ao_lisp_v = v;
+ ao_lisp_stack->values = AO_LISP_NIL;
+ ao_lisp_stack->values_tail = AO_LISP_NIL;
DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n");
DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
break;
ao_lisp_stack->state = eval_progn;
v = ao_lisp_lambda_eval();
ao_lisp_stack->sexprs = v;
+ ao_lisp_stack->values = AO_LISP_NIL;
+ ao_lisp_stack->values_tail = AO_LISP_NIL;
DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n");
DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
break;
+ case AO_LISP_STACK:
+ DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n");
+ ao_lisp_v = ao_lisp_stack_eval();
+ DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n");
+ DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");
+ break;
}
- ao_lisp_stack->values = AO_LISP_NIL;
- ao_lisp_stack->values_tail = AO_LISP_NIL;
return 1;
}
[eval_macro] = ao_lisp_eval_macro,
};
+const char *ao_lisp_state_names[] = {
+ "sexpr",
+ "val",
+ "formal",
+ "exec",
+ "cond",
+ "cond_test",
+ "progn",
+};
+
/*
* Called at restore time to reset all execution state
*/
frame_size(void *addr)
{
struct ao_lisp_frame *frame = addr;
- return frame_num_size(ao_lisp_frame_num(frame));
+ return frame_num_size(frame->num);
}
static void
MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame));
if (!AO_LISP_IS_POOL(frame))
break;
- for (f = 0; f < ao_lisp_frame_num(frame); f++) {
+ for (f = 0; f < frame->num; f++) {
struct ao_lisp_val *v = &frame->vals[f];
ao_lisp_poly_mark(v->val, 0);
MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame));
if (!AO_LISP_IS_POOL(frame))
break;
- for (f = 0; f < ao_lisp_frame_num(frame); f++) {
+ for (f = 0; f < frame->num; f++) {
struct ao_lisp_val *v = &frame->vals[f];
ao_lisp_poly_move(&v->atom, 0);
printf ("{");
if (frame) {
- for (f = 0; f < ao_lisp_frame_num(frame); f++) {
- if (f != 0)
- printf(", ");
- ao_lisp_poly_print(frame->vals[f].atom);
- printf(" = ");
- ao_lisp_poly_print(frame->vals[f].val);
+ if (frame->type & AO_LISP_FRAME_PRINT)
+ printf("recurse...");
+ else {
+ frame->type |= AO_LISP_FRAME_PRINT;
+ for (f = 0; f < frame->num; f++) {
+ if (f != 0)
+ printf(", ");
+ ao_lisp_poly_print(frame->vals[f].atom);
+ printf(" = ");
+ ao_lisp_poly_print(frame->vals[f].val);
+ }
+ if (frame->prev)
+ ao_lisp_poly_print(frame->prev);
+ frame->type &= ~AO_LISP_FRAME_PRINT;
}
- if (frame->prev)
- ao_lisp_poly_print(frame->prev);
}
printf("}");
}
ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom)
{
int f;
- for (f = 0; f < ao_lisp_frame_num(frame); f++)
+ for (f = 0; f < frame->num; f++)
if (frame->vals[f].atom == atom)
return &frame->vals[f].val;
return NULL;
return NULL;
}
frame->type = AO_LISP_FRAME;
- frame->_num = num;
+ frame->num = num;
frame->prev = AO_LISP_NIL;
memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val));
return frame;
{
if (!frame)
return AO_LISP_NIL;
- frame->_num |= AO_LISP_FRAME_MARK;
+ frame->type |= AO_LISP_FRAME_MARK;
return ao_lisp_frame_poly(frame);
}
ao_lisp_frame_free(struct ao_lisp_frame *frame)
{
if (!ao_lisp_frame_marked(frame)) {
- int num = ao_lisp_frame_num(frame);
+ int num = frame->num;
if (num < AO_LISP_FRAME_FREE) {
frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]);
ao_lisp_frame_free_list[num] = frame;
struct ao_lisp_frame *new;
int copy;
- if (new_num == ao_lisp_frame_num(frame))
+ if (new_num == frame->num)
return frame;
new = ao_lisp_frame_new(new_num);
if (!new)
*/
frame = *frame_ref;
copy = new_num;
- if (copy > ao_lisp_frame_num(frame))
- copy = ao_lisp_frame_num(frame);
+ if (copy > frame->num)
+ copy = frame->num;
memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val));
new->prev = frame->prev;
ao_lisp_frame_free(frame);
ao_lisp_poly_stash(0, atom);
ao_lisp_poly_stash(1, val);
if (frame) {
- f = ao_lisp_frame_num(frame);
+ f = frame->num;
frame = ao_lisp_frame_realloc(frame_ref, f + 1);
} else {
f = 0;
args = ao_lisp_poly_cons(args->cdr);
vals = ao_lisp_poly_cons(vals->cdr);
}
- ao_lisp_cons_free(cons);
+ if (!ao_lisp_stack_marked(ao_lisp_stack))
+ ao_lisp_cons_free(cons);
cons = NULL;
break;
case AO_LISP_FUNC_LEXPR:
{ .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led },
{ .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save },
{ .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore },
+ { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc },
};
#define N_FUNC (sizeof funcs / sizeof funcs[0])
/* Reduce to referenced values */
ao_lisp_collect(AO_LISP_COLLECT_FULL);
- for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) {
+ for (f = 0; f < ao_lisp_frame_global->num; f++) {
val = ao_has_macro(ao_lisp_frame_global->vals[f].val);
if (val != AO_LISP_NIL) {
printf("error: function %s contains unresolved macro: ",
static struct ao_lisp_cons *save_cons[2];
static char *save_string[2];
+static struct ao_lisp_stack *save_stack[3];
static ao_poly save_poly[2];
static const struct ao_lisp_root ao_lisp_root[] = {
.type = &ao_lisp_cons_type,
.addr = (void **) &save_cons[1],
},
+ {
+ .type = &ao_lisp_stack_type,
+ .addr = (void **) &save_stack[0]
+ },
+ {
+ .type = &ao_lisp_stack_type,
+ .addr = (void **) &save_stack[1]
+ },
+ {
+ .type = &ao_lisp_stack_type,
+ .addr = (void **) &save_stack[2]
+ },
{
.type = &ao_lisp_string_type,
.addr = (void **) &save_string[0]
[AO_LISP_BUILTIN] = &ao_lisp_builtin_type,
[AO_LISP_FRAME] = &ao_lisp_frame_type,
[AO_LISP_LAMBDA] = &ao_lisp_lambda_type,
+ [AO_LISP_STACK] = &ao_lisp_stack_type,
};
static int
return cons;
}
+void
+ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack)
+{
+ save_stack[id] = stack;
+}
+
+struct ao_lisp_stack *
+ao_lisp_stack_fetch(int id)
+{
+ struct ao_lisp_stack *stack = save_stack[id];
+ save_stack[id] = NULL;
+ return stack;
+}
+
void
ao_lisp_string_stash(int id, char *string)
{
.print = ao_lisp_lambda_print,
.patom = ao_lisp_lambda_print,
},
+ [AO_LISP_STACK] = {
+ .print = ao_lisp_stack_print,
+ .patom = ao_lisp_stack_print,
+ },
};
static const struct ao_lisp_funcs *
--- /dev/null
+/*
+ * Copyright © 2016 Keith Packard <keithp@keithp.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ */
+
+#define DBG_EVAL 0
+#include "ao_lisp.h"
+
+const struct ao_lisp_type ao_lisp_stack_type;
+
+static int
+stack_size(void *addr)
+{
+ (void) addr;
+ return sizeof (struct ao_lisp_stack);
+}
+
+static void
+stack_mark(void *addr)
+{
+ struct ao_lisp_stack *stack = addr;
+ for (;;) {
+ ao_lisp_poly_mark(stack->sexprs, 0);
+ ao_lisp_poly_mark(stack->values, 0);
+ /* no need to mark values_tail */
+ ao_lisp_poly_mark(stack->frame, 0);
+ ao_lisp_poly_mark(stack->list, 0);
+ stack = ao_lisp_poly_stack(stack->prev);
+ if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack))
+ break;
+ }
+}
+
+static void
+stack_move(void *addr)
+{
+ struct ao_lisp_stack *stack = addr;
+
+ while (stack) {
+ struct ao_lisp_stack *prev;
+ int ret;
+ (void) ao_lisp_poly_move(&stack->sexprs, 0);
+ (void) ao_lisp_poly_move(&stack->values, 0);
+ (void) ao_lisp_poly_move(&stack->values_tail, 0);
+ (void) ao_lisp_poly_move(&stack->frame, 0);
+ (void) ao_lisp_poly_move(&stack->list, 0);
+ prev = ao_lisp_poly_stack(stack->prev);
+ if (!prev)
+ break;
+ ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev);
+ if (prev != ao_lisp_poly_stack(stack->prev))
+ stack->prev = ao_lisp_stack_poly(prev);
+ if (ret)
+ break;
+ stack = prev;
+ }
+}
+
+const struct ao_lisp_type ao_lisp_stack_type = {
+ .size = stack_size,
+ .mark = stack_mark,
+ .move = stack_move,
+ .name = "stack"
+};
+
+struct ao_lisp_stack *ao_lisp_stack_free_list;
+
+void
+ao_lisp_stack_reset(struct ao_lisp_stack *stack)
+{
+ stack->state = eval_sexpr;
+ stack->sexprs = AO_LISP_NIL;
+ stack->values = AO_LISP_NIL;
+ stack->values_tail = AO_LISP_NIL;
+}
+
+static struct ao_lisp_stack *
+ao_lisp_stack_new(void)
+{
+ struct ao_lisp_stack *stack;
+
+ if (ao_lisp_stack_free_list) {
+ stack = ao_lisp_stack_free_list;
+ ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev);
+ } else {
+ stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
+ if (!stack)
+ return 0;
+ stack->type = AO_LISP_STACK;
+ }
+ ao_lisp_stack_reset(stack);
+ return stack;
+}
+
+int
+ao_lisp_stack_push(void)
+{
+ struct ao_lisp_stack *stack = ao_lisp_stack_new();
+
+ if (!stack)
+ return 0;
+
+ stack->prev = ao_lisp_stack_poly(ao_lisp_stack);
+ stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
+ stack->list = AO_LISP_NIL;
+
+ ao_lisp_stack = stack;
+
+ DBGI("stack push\n");
+ DBG_FRAMES();
+ DBG_IN();
+ return 1;
+}
+
+void
+ao_lisp_stack_pop(void)
+{
+ ao_poly prev;
+ struct ao_lisp_frame *prev_frame;
+
+ if (!ao_lisp_stack)
+ return;
+ prev = ao_lisp_stack->prev;
+ if (!ao_lisp_stack_marked(ao_lisp_stack)) {
+ ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list);
+ ao_lisp_stack_free_list = ao_lisp_stack;
+ }
+
+ ao_lisp_stack = ao_lisp_poly_stack(prev);
+ prev_frame = ao_lisp_frame_current;
+ if (ao_lisp_stack)
+ ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
+ else
+ ao_lisp_frame_current = NULL;
+ if (ao_lisp_frame_current != prev_frame)
+ ao_lisp_frame_free(prev_frame);
+ DBG_OUT();
+ DBGI("stack pop\n");
+ DBG_FRAMES();
+}
+
+void
+ao_lisp_stack_clear(void)
+{
+ ao_lisp_stack = NULL;
+ ao_lisp_frame_current = NULL;
+ ao_lisp_v = AO_LISP_NIL;
+}
+
+void
+ao_lisp_stack_print(ao_poly poly)
+{
+ struct ao_lisp_stack *s = ao_lisp_poly_stack(poly);
+
+ if (s->type & AO_LISP_STACK_PRINT) {
+ printf("[recurse...]");
+ return;
+ }
+ while (s) {
+ s->type |= AO_LISP_STACK_PRINT;
+ printf("\t[\n");
+ printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n");
+ printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]);
+ ao_lisp_error_poly ("values: ", s->values, s->values_tail);
+ ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL);
+ ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame));
+ printf("\t]\n");
+ s->type &= ~AO_LISP_STACK_PRINT;
+ s = ao_lisp_poly_stack(s->prev);
+ }
+}
+
+/*
+ * Copy a stack, being careful to keep everybody referenced
+ */
+static struct ao_lisp_stack *
+ao_lisp_stack_copy(struct ao_lisp_stack *old)
+{
+ struct ao_lisp_stack *new = NULL;
+ struct ao_lisp_stack *n, *prev = NULL;
+
+ while (old) {
+ ao_lisp_stack_stash(0, old);
+ ao_lisp_stack_stash(1, new);
+ ao_lisp_stack_stash(2, prev);
+ n = ao_lisp_stack_new();
+ prev = ao_lisp_stack_fetch(2);
+ new = ao_lisp_stack_fetch(1);
+ old = ao_lisp_stack_fetch(0);
+ if (!n)
+ return NULL;
+
+ ao_lisp_stack_mark(old);
+ ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame));
+ *n = *old;
+
+ if (prev)
+ prev->prev = ao_lisp_stack_poly(n);
+ else
+ new = n;
+ prev = n;
+
+ old = ao_lisp_poly_stack(old->prev);
+ }
+ return new;
+}
+
+/*
+ * Evaluate a continuation invocation
+ */
+ao_poly
+ao_lisp_stack_eval(void)
+{
+ struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v));
+ if (!new)
+ return AO_LISP_NIL;
+
+ struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values);
+
+ if (!cons || !cons->cdr)
+ return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value");
+
+ new->state = eval_val;
+
+ ao_lisp_stack = new;
+ ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame);
+
+ return ao_lisp_poly_cons(cons->cdr)->car;
+}
+
+/*
+ * Call with current continuation. This calls a lambda, passing
+ * it a single argument which is the current continuation
+ */
+ao_poly
+ao_lisp_call_cc(struct ao_lisp_cons *cons)
+{
+ struct ao_lisp_stack *new;
+ ao_poly v;
+
+ /* Make sure the single parameter is a lambda */
+ if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1))
+ return AO_LISP_NIL;
+ if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0))
+ return AO_LISP_NIL;
+
+ /* go get the lambda */
+ ao_lisp_v = ao_lisp_arg(cons, 0);
+
+ /* Note that the whole call chain now has
+ * a reference to it which may escape
+ */
+ new = ao_lisp_stack_copy(ao_lisp_stack);
+ if (!new)
+ return AO_LISP_NIL;
+
+ /* re-fetch cons after the allocation */
+ cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr);
+
+ /* Reset the arg list to the current stack,
+ * and call the lambda
+ */
+
+ cons->car = ao_lisp_stack_poly(new);
+ cons->cdr = AO_LISP_NIL;
+ v = ao_lisp_lambda_eval();
+ ao_lisp_stack->sexprs = v;
+ ao_lisp_stack->state = eval_progn;
+ return AO_LISP_NIL;
+}
projects / fw / altos / commitdiff