]> git.gag.com Git - fw/altos/commitdiff
altos/lisp: Add continuations
authorKeith Packard <keithp@keithp.com>
Sat, 19 Nov 2016 03:04:05 +0000 (19:04 -0800)
committerKeith Packard <keithp@keithp.com>
Sat, 19 Nov 2016 03:04:05 +0000 (19:04 -0800)
This provides call/cc and makes 'stacks' visible to the application.

Signed-off-by: Keith Packard <keithp@keithp.com>
src/lisp/Makefile
src/lisp/ao_lisp.h
src/lisp/ao_lisp_builtin.c
src/lisp/ao_lisp_error.c
src/lisp/ao_lisp_eval.c
src/lisp/ao_lisp_frame.c
src/lisp/ao_lisp_lambda.c
src/lisp/ao_lisp_make_const.c
src/lisp/ao_lisp_mem.c
src/lisp/ao_lisp_poly.c
src/lisp/ao_lisp_stack.c [new file with mode: 0644]

index 152979996621b19f23257f6e04cdbdfb9eb8db7b..dd5a0cb44bf5ba4f55f04878c27b796e7d3536e4 100644 (file)
@@ -21,6 +21,7 @@ SRCS=\
        ao_lisp_eval.c \
        ao_lisp_rep.c \
        ao_lisp_save.c \
+       ao_lisp_stack.c \
        ao_lisp_error.c 
 
 OBJS=$(SRCS:.c=.o)
index bcefbabf76abeae8fb3b2fae8166bc48c362660d..a8e1715a8dc88bd3ca8cc4e79e5823b4b3561efc 100644 (file)
@@ -75,6 +75,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST];
 #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
@@ -99,7 +100,11 @@ extern uint8_t              ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA];
 #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
 
@@ -153,22 +158,17 @@ struct ao_lisp_val {
 
 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 *
@@ -195,6 +195,7 @@ enum eval_state {
 };
 
 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 */
@@ -204,6 +205,17 @@ struct ao_lisp_stack {
        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)
 {
@@ -216,8 +228,6 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack)
        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
@@ -276,6 +286,7 @@ enum ao_lisp_builtin_id {
        builtin_led,
        builtin_save,
        builtin_restore,
+       builtin_call_cc,
        _builtin_last
 };
 
@@ -315,7 +326,7 @@ ao_lisp_poly_other(ao_poly poly) {
 
 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
@@ -455,6 +466,12 @@ ao_lisp_string_stash(int id, char *string);
 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);
 
@@ -617,6 +634,8 @@ ao_lisp_frame_print(ao_poly p);
 /* 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);
 
@@ -646,12 +665,40 @@ ao_lisp_save(struct ao_lisp_cons *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, ...);
index 6cbcb92cb401624cb3f2653da3da0f1f7a763534..4c845307b45ac5b101b07faf7923646778a29c31 100644 (file)
@@ -86,6 +86,7 @@ static const ao_poly builtin_names[] = {
        [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,
 
 };
 
@@ -117,9 +118,7 @@ void
 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
@@ -599,5 +598,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = {
        [builtin_delay] = ao_lisp_delay,
        [builtin_save] = ao_lisp_save,
        [builtin_restore] = ao_lisp_restore,
+       [builtin_call_cc] = ao_lisp_call_cc,
 };
 
index 937739e97259701cec8a496fd7d5ea8eae02d2c2..54a9be109214547b9f1794b8acfb08cb0c5268e7 100644 (file)
 #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
@@ -48,7 +49,7 @@ static void tabs(int indent)
                printf("\t");
 }
 
-static void
+void
 ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame)
 {
        int                     f;
@@ -56,51 +57,30 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame)
        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, ...)
@@ -112,7 +92,9 @@ 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");
index ef521605764fd1d1a013079149d826963ef4d763..2460a32a3a8e9f6dc18002d21ba3f1f4e91df237 100644 (file)
 #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)
 {
@@ -86,72 +27,6 @@ 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)
 {
@@ -162,6 +37,8 @@ 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;
@@ -392,10 +269,12 @@ ao_lisp_eval_exec(void)
                                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;
@@ -404,12 +283,18 @@ ao_lisp_eval_exec(void)
                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;
 }
 
@@ -599,6 +484,16 @@ static int (*const evals[])(void) = {
        [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
  */
index 9d17f6fa37d12946e3d12952c127996d243fb5c6..17fa141a00e014aec425b78303e3faded572241c 100644 (file)
@@ -24,7 +24,7 @@ static int
 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
@@ -37,7 +37,7 @@ frame_mark(void *addr)
                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);
@@ -68,7 +68,7 @@ frame_move(void *addr)
                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);
@@ -109,15 +109,21 @@ ao_lisp_frame_print(ao_poly p)
 
        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("}");
 }
@@ -126,7 +132,7 @@ ao_poly *
 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;
@@ -175,7 +181,7 @@ ao_lisp_frame_new(int num)
                        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;
@@ -186,7 +192,7 @@ ao_lisp_frame_mark(struct ao_lisp_frame *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);
 }
 
@@ -194,7 +200,7 @@ void
 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;
@@ -209,7 +215,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num)
        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)
@@ -220,8 +226,8 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num)
         */
        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);
@@ -239,7 +245,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val)
                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;
index e2053a6f3d4302e15e17c75c3dfe21cc8be90258..656936cb88c691b10077b5543fb2693d56dfbe34 100644 (file)
@@ -175,7 +175,8 @@ ao_lisp_lambda_eval(void)
                        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:
index 495e48cd2e5f5656642ec8ba3a14e82b049b0c52..de9c57251bc954378b00bd2f134e69f445a1f468 100644 (file)
@@ -71,6 +71,7 @@ struct builtin_func funcs[] = {
        { .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])
@@ -358,7 +359,7 @@ main(int argc, char **argv)
        /* 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: ",
index 12a5ba5502a32e158f284c8864de7028ef5d18cf..0dfad1d7c87bcc6286b924698730a63a849c3dcb 100644 (file)
@@ -144,6 +144,7 @@ struct ao_lisp_root {
 
 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[] = {
@@ -155,6 +156,18 @@ 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]
@@ -434,6 +447,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = {
        [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
@@ -818,6 +832,20 @@ ao_lisp_cons_fetch(int id)
        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)
 {
index 236176e76baffc91fc0bfeeedc9c78511b6d465d..800ee06d88df1811cf39b03de5fd01ee52501d8d 100644 (file)
@@ -54,6 +54,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = {
                .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 *
diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c
new file mode 100644 (file)
index 0000000..9c773e8
--- /dev/null
@@ -0,0 +1,279 @@
+/*
+ * 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;
+}