altos: Add lambda support to lisp
authorKeith Packard <keithp@keithp.com>
Fri, 4 Nov 2016 04:49:50 +0000 (21:49 -0700)
committerKeith Packard <keithp@keithp.com>
Mon, 20 Feb 2017 19:16:49 +0000 (11:16 -0800)
Signed-off-by: Keith Packard <keithp@keithp.com>
14 files changed:
src/lisp/Makefile
src/lisp/ao_lisp.h
src/lisp/ao_lisp_atom.c
src/lisp/ao_lisp_builtin.c
src/lisp/ao_lisp_const.lisp
src/lisp/ao_lisp_error.c [new file with mode: 0644]
src/lisp/ao_lisp_eval.c
src/lisp/ao_lisp_frame.c
src/lisp/ao_lisp_make_const.c
src/lisp/ao_lisp_rep.c
src/nucleao-32/Makefile
src/nucleao-32/ao_pins.h
src/test/Makefile
src/test/ao_lisp_test.c

index 9e2fb58c0fdcb6a9e1dd6fc96df0a5b27197da8a..be19b432f7e58183b95198f461412a264ba3ddb6 100644 (file)
@@ -17,7 +17,8 @@ SRCS=\
        ao_lisp_prim.c \
        ao_lisp_builtin.c \
        ao_lisp_read.c \
-       ao_lisp_frame.c
+       ao_lisp_frame.c \
+       ao_lisp_error.c
 
 OBJS=$(SRCS:.c=.o)
 
index 98e99acbaec768d4467521f946f19f9741a0be3e..9a5cc63e22e639a7e7120bc88192ca2196961118 100644 (file)
 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST];
 #define ao_lisp_pool ao_lisp_const
 #define AO_LISP_POOL AO_LISP_POOL_CONST
-#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote"))
-#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set"))
+
+#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n))
+
+#define _ao_lisp_atom_quote    _atom("quote")
+#define _ao_lisp_atom_set      _atom("set")
+#define _ao_lisp_atom_setq     _atom("setq")
+#define _ao_lisp_atom_t        _atom("t")
+#define _ao_lisp_atom_car      _atom("car")
+#define _ao_lisp_atom_cdr      _atom("cdr")
+#define _ao_lisp_atom_cons     _atom("cons")
+#define _ao_lisp_atom_cond     _atom("cond")
 #else
 #include "ao_lisp_const.h"
+#ifndef AO_LISP_POOL
 #define AO_LISP_POOL   1024
+#endif
 extern uint8_t         ao_lisp_pool[AO_LISP_POOL];
 #endif
 
@@ -68,6 +79,7 @@ extern uint16_t               ao_lisp_top;
 extern uint8_t         ao_lisp_exception;
 
 typedef uint16_t       ao_poly;
+typedef int16_t                ao_signed_poly;
 
 static inline int
 ao_lisp_is_const(ao_poly poly) {
@@ -157,6 +169,7 @@ enum ao_lisp_builtin_id {
        builtin_quote,
        builtin_set,
        builtin_setq,
+       builtin_cond,
        builtin_print,
        builtin_plus,
        builtin_minus,
@@ -222,13 +235,13 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons)
 static inline int
 ao_lisp_poly_int(ao_poly poly)
 {
-       return (int) poly >> AO_LISP_TYPE_SHIFT;
+       return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT);
 }
 
 static inline ao_poly
 ao_lisp_int_poly(int i)
 {
-       return ((ao_poly) i << 2) + AO_LISP_INT;
+       return ((ao_poly) i << 2) | AO_LISP_INT;
 }
 
 static inline char *
@@ -326,8 +339,7 @@ extern const struct ao_lisp_type ao_lisp_atom_type;
 
 extern struct ao_lisp_atom *ao_lisp_atoms;
 
-void
-ao_lisp_atom_init(void);
+extern struct ao_lisp_frame *ao_lisp_frame_current;
 
 void
 ao_lisp_atom_print(ao_poly a);
@@ -359,12 +371,27 @@ ao_lisp_poly_move(ao_poly p);
 ao_poly
 ao_lisp_eval(ao_poly p);
 
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *cons);
+
 /* builtin */
 void
 ao_lisp_builtin_print(ao_poly b);
 
 extern const struct ao_lisp_type ao_lisp_builtin_type;
 
+/* Check argument count */
+ao_poly
+ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max);
+
+/* Check argument type */
+ao_poly
+ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok);
+
+/* Fetch an arg (nil if off the end) */
+ao_poly
+ao_lisp_arg(struct ao_lisp_cons *cons, int argc);
+
 /* read */
 ao_poly
 ao_lisp_read(void);
@@ -376,11 +403,8 @@ ao_lisp_read_eval_print(void);
 /* frame */
 extern const struct ao_lisp_type ao_lisp_frame_type;
 
-int
-ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val);
-
-ao_poly
-ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom);
+ao_poly *
+ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom);
 
 struct ao_lisp_frame *
 ao_lisp_frame_new(int num, int readonly);
@@ -388,4 +412,9 @@ ao_lisp_frame_new(int num, int readonly);
 struct ao_lisp_frame *
 ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val);
 
+/* error */
+
+ao_poly
+ao_lisp_error(int error, char *format, ...);
+
 #endif /* _AO_LISP_H_ */
index e5d28c3ba2801bf86ec8f4f74d9c33d4353c1b71..ea04741e2b2c01c7201f85cc49e0fc99af7102dd 100644 (file)
@@ -109,31 +109,65 @@ ao_lisp_atom_intern(char *name)
        return atom;
 }
 
-static struct ao_lisp_frame    *globals;
+static struct ao_lisp_frame    *ao_lisp_frame_global;
+struct ao_lisp_frame           *ao_lisp_frame_current;
+
+static void
+ao_lisp_atom_init(void)
+{
+       if (!ao_lisp_frame_global) {
+               ao_lisp_frame_global = ao_lisp_frame_new(0, 0);
+               ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global);
+               ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current);
+       }
+}
+
+static ao_poly *
+ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom)
+{
+       ao_poly *ref;
+       ao_lisp_atom_init();
+       while (frame) {
+               ref = ao_lisp_frame_ref(frame, atom);
+               if (ref)
+                       return ref;
+               frame = ao_lisp_poly_frame(frame->next);
+       }
+       if (ao_lisp_frame_global) {
+               ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
+               if (ref)
+                       return ref;
+       }
+       return NULL;
+}
 
 ao_poly
 ao_lisp_atom_get(ao_poly atom)
 {
-       struct ao_lisp_frame    *frame = globals;
+       ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+
+       if (!ref && ao_lisp_frame_global)
+               ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
 #ifdef ao_builtin_frame
-       if (!frame)
-               frame = ao_lisp_poly_frame(ao_builtin_frame);
+       if (!ref)
+               ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom);
 #endif
-       return ao_lisp_frame_get(frame, atom);
+       if (ref)
+               return *ref;
+       return AO_LISP_NIL;
 }
 
 ao_poly
 ao_lisp_atom_set(ao_poly atom, ao_poly val)
 {
-       if (!ao_lisp_frame_set(globals, atom, val)) {
-               globals = ao_lisp_frame_add(globals, atom, val);
-               if (!globals->next) {
-                       ao_lisp_root_add(&ao_lisp_frame_type, &globals);
-#ifdef ao_builtin_frame
-                       globals->next = ao_builtin_frame;
-#endif
-               }
-       }
+       ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom);
+
+       if (!ref && ao_lisp_frame_global)
+               ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom);
+       if (ref)
+               *ref = val;
+       else
+               ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val);
        return val;
 }
 
index 8c481793bcf3f6a0c9c64bf0eb2e0f7ed2bd8e5f..2976bc95dab1c5c5495defdb114bb4b06fe02497 100644 (file)
@@ -46,7 +46,8 @@ ao_lisp_builtin_print(ao_poly b)
        printf("[builtin]");
 }
 
-static int check_argc(struct ao_lisp_cons *cons, int min, int max)
+ao_poly
+ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max)
 {
        int     argc = 0;
 
@@ -54,28 +55,30 @@ static int check_argc(struct ao_lisp_cons *cons, int min, int max)
                argc++;
                cons = ao_lisp_poly_cons(cons->cdr);
        }
-       if (argc < min || argc > max) {
-               ao_lisp_exception |= AO_LISP_INVALID;
-               return 0;
-       }
-       return 1;
+       if (argc < min || argc > max)
+               return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name);
+       return _ao_lisp_atom_t;
 }
 
-static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
+ao_poly
+ao_lisp_arg(struct ao_lisp_cons *cons, int argc)
 {
-       ao_poly car;
-
-       /* find the desired arg */
-       while (argc--)
+       while (argc--) {
+               if (!cons)
+                       return AO_LISP_NIL;
                cons = ao_lisp_poly_cons(cons->cdr);
-       car = cons->car;
-       if ((!car && !nil_ok) ||
-           ao_lisp_poly_type(car) != type)
-       {
-               ao_lisp_exception |= AO_LISP_INVALID;
-               return 0;
        }
-       return 1;
+       return cons->car;
+}
+
+ao_poly
+ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
+{
+       ao_poly car = ao_lisp_arg(cons, argc);
+
+       if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type)
+               return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc);
+       return _ao_lisp_atom_t;
 }
 
 enum math_op { math_plus, math_minus, math_times, math_divide, math_mod };
@@ -83,30 +86,20 @@ enum math_op { math_plus, math_minus, math_times, math_divide, math_mod };
 ao_poly
 ao_lisp_car(struct ao_lisp_cons *cons)
 {
-       if (!check_argc(cons, 1, 1))
+       if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1))
                return AO_LISP_NIL;
-       if (!check_argt(cons, 0, AO_LISP_CONS, 0)) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0))
                return AO_LISP_NIL;
-       }
        return ao_lisp_poly_cons(cons->car)->car;
 }
 
 ao_poly
 ao_lisp_cdr(struct ao_lisp_cons *cons)
 {
-       if (!cons) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1))
                return AO_LISP_NIL;
-       }
-       if (!cons->car) {
-               ao_lisp_exception |= AO_LISP_INVALID;
-               return AO_LISP_NIL;
-       }
-       if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0))
                return AO_LISP_NIL;
-       }
        return ao_lisp_poly_cons(cons->car)->cdr;
 }
 
@@ -114,50 +107,39 @@ ao_poly
 ao_lisp_cons(struct ao_lisp_cons *cons)
 {
        ao_poly car, cdr;
-       if (!cons) {
-               ao_lisp_exception |= AO_LISP_INVALID;
-               return AO_LISP_NIL;
-       }
-       car = cons->car;
-       cdr = cons->cdr;
-       if (!car || !cdr) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2))
                return AO_LISP_NIL;
-       }
-       cdr = ao_lisp_poly_cons(cdr)->car;
-       if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1))
                return AO_LISP_NIL;
-       }
+       car = ao_lisp_arg(cons, 0);
+       cdr = ao_lisp_arg(cons, 1);
        return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr)));
 }
 
 ao_poly
 ao_lisp_quote(struct ao_lisp_cons *cons)
 {
-       if (!cons) {
-               ao_lisp_exception |= AO_LISP_INVALID;
+       if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1))
                return AO_LISP_NIL;
-       }
-       return cons->car;
+       return ao_lisp_arg(cons, 0);
 }
 
 ao_poly
 ao_lisp_set(struct ao_lisp_cons *cons)
 {
-       if (!check_argc(cons, 2, 2))
+       if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2))
                return AO_LISP_NIL;
-       if (!check_argt(cons, 0, AO_LISP_ATOM, 0))
+       if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0))
                return AO_LISP_NIL;
 
-       return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car);
+       return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_poly_cons(ao_lisp_arg(cons, 1))->car);
 }
 
 ao_poly
 ao_lisp_setq(struct ao_lisp_cons *cons)
 {
        struct ao_lisp_cons     *expand = 0;
-       if (!check_argc(cons, 2, 2))
+       if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2))
                return AO_LISP_NIL;
        expand = ao_lisp_cons_cons(_ao_lisp_atom_set,
                                   ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote,
@@ -166,6 +148,22 @@ ao_lisp_setq(struct ao_lisp_cons *cons)
        return ao_lisp_cons_poly(expand);
 }
 
+ao_poly
+ao_lisp_cond(struct ao_lisp_cons *cons)
+{
+       int                     argc;
+       struct ao_lisp_cons     *arg;
+
+       argc = 0;
+       for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) {
+               if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS)
+                       return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d",
+                                            ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc);
+       }
+       ao_lisp_set_cond(cons);
+       return AO_LISP_NIL;
+}
+
 ao_poly
 ao_lisp_print(struct ao_lisp_cons *cons)
 {
@@ -210,17 +208,13 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op)
                                r *= c;
                                break;
                        case math_divide:
-                               if (c == 0) {
-                                       ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
-                                       return AO_LISP_NIL;
-                               }
+                               if (c == 0)
+                                       return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
                                r /= c;
                                break;
                        case math_mod:
-                               if (c == 0) {
-                                       ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO;
-                                       return AO_LISP_NIL;
-                               }
+                               if (c == 0)
+                                       return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero");
                                r %= c;
                                break;
                        }
@@ -230,10 +224,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op)
                else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus)
                        ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret),
                                                                     ao_lisp_poly_string(car)));
-               else {
-                       ao_lisp_exception |= AO_LISP_INVALID;
-                       return AO_LISP_NIL;
-               }
+               else
+                       return ao_lisp_error(AO_LISP_INVALID, "invalid args");
        }
        return ret;
 }
@@ -275,6 +267,7 @@ ao_lisp_func_t ao_lisp_builtins[] = {
        [builtin_quote] = ao_lisp_quote,
        [builtin_set] = ao_lisp_set,
        [builtin_setq] = ao_lisp_setq,
+       [builtin_cond] = ao_lisp_cond,
        [builtin_print] = ao_lisp_print,
        [builtin_plus] = ao_lisp_plus,
        [builtin_minus] = ao_lisp_minus,
index aa356d450aeeaa87d5860ec5948a37dec69cf77c..5ee15899912d428c79ce52efb497d1190b8846fd 100644 (file)
@@ -1 +1,4 @@
 cadr (lambda (l) (car (cdr l)))
+list (lexpr (l) l)
+1+ (lambda (x) (+ x 1))
+1- (lambda (x) (- x 1))
diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c
new file mode 100644 (file)
index 0000000..ea8111d
--- /dev/null
@@ -0,0 +1,29 @@
+/*
+ * 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.
+ */
+
+#include "ao_lisp.h"
+#include <stdarg.h>
+
+ao_poly
+ao_lisp_error(int error, char *format, ...)
+{
+       va_list args;
+
+       ao_lisp_exception |= error;
+       va_start(args, format);
+       vprintf(format, args);
+       va_end(args);
+       printf("\n");
+       return AO_LISP_NIL;
+}
index 6eef1f23d148f08c1b5ac4c094be412b472ef209..803f1e2ed11de17291b9725c9747f23d70fe0a65 100644 (file)
 
 #include "ao_lisp.h"
 
-/*
- * Non-recursive eval
- *
- * Plan: walk actuals, construct formals
- *
- * stack >  save  > actuals > actual_1
- *           v         v
- *        formals     .    > actual_2
- */
-
-static struct ao_lisp_cons     *stack;
-static struct ao_lisp_cons     *actuals;
-static struct ao_lisp_cons     *formals;
-static struct ao_lisp_cons     *formals_tail;
-static uint8_t been_here;
-
 #if 0
 #define DBG(...) printf(__VA_ARGS__)
-#define DBG_CONS(a)    ao_lisp_cons_print(a)
+#define DBG_CONS(a)    ao_lisp_cons_print(ao_lisp_cons_poly(a))
 #define DBG_POLY(a)    ao_lisp_poly_print(a)
+#define OFFSET(a)      ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1)
 #else
 #define DBG(...)
 #define DBG_CONS(a)
 #define DBG_POLY(a)
 #endif
 
+struct ao_lisp_stack {
+       ao_poly                 next;
+       ao_poly                 actuals;
+       ao_poly                 formals;
+       ao_poly                 frame;
+       ao_poly                 cond;
+};
+
+static struct ao_lisp_stack *
+ao_lisp_poly_stack(ao_poly p)
+{
+       return ao_lisp_ref(p);
+}
+
+static ao_poly
+ao_lisp_stack_poly(struct ao_lisp_stack *stack)
+{
+       return ao_lisp_poly(stack, AO_LISP_OTHER);
+}
+
+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->actuals);
+               ao_lisp_poly_mark(stack->formals);
+               ao_lisp_poly_mark(stack->frame);
+               ao_lisp_poly_mark(stack->cond);
+               stack = ao_lisp_poly_stack(stack->next);
+               if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack)))
+                       break;
+       }
+}
+
+static void
+stack_move(void *addr)
+{
+       struct ao_lisp_stack    *stack = addr;
+
+       for (;;) {
+               struct ao_lisp_stack *next;
+               stack->actuals = ao_lisp_poly_move(stack->actuals);
+               stack->formals = ao_lisp_poly_move(stack->formals);
+               stack->frame = ao_lisp_poly_move(stack->frame);
+               stack->cond = ao_lisp_poly_move(stack->cond);
+               next = ao_lisp_ref(stack->next);
+               next = ao_lisp_move_memory(next, sizeof (struct ao_lisp_stack));
+               stack->next = ao_lisp_stack_poly(next);
+               stack = next;
+       }
+}
+
+static const struct ao_lisp_type ao_lisp_stack_type = {
+       .size = stack_size,
+       .mark = stack_mark,
+       .move = stack_move
+};
+
+
+static struct ao_lisp_stack    *stack;
+static struct ao_lisp_cons     *actuals;
+static struct ao_lisp_cons     *formals;
+static struct ao_lisp_cons     *formals_tail;
+static struct ao_lisp_cons     *cond;
+struct ao_lisp_frame           *next_frame;
+static uint8_t been_here;
+
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *c)
+{
+       cond = c;
+       return AO_LISP_NIL;
+}
+
+static int
+ao_lisp_stack_push(void)
+{
+       struct ao_lisp_stack    *n = ao_lisp_alloc(sizeof (struct ao_lisp_stack));
+       if (!n)
+               return 0;
+       n->next = ao_lisp_stack_poly(stack);
+       n->actuals = ao_lisp_cons_poly(actuals);
+       n->formals = ao_lisp_cons_poly(formals);
+       n->cond = ao_lisp_cons_poly(cond);
+       n->frame = ao_lisp_frame_poly(ao_lisp_frame_current);
+       DBG("push frame %d\n", OFFSET(ao_lisp_frame_current));
+       stack = n;
+       return 1;
+}
+
+static void
+ao_lisp_stack_pop(void)
+{
+       actuals = ao_lisp_poly_cons(stack->actuals);
+       formals = ao_lisp_poly_cons(stack->formals);
+       cond = ao_lisp_poly_cons(stack->cond);
+       ao_lisp_frame_current = ao_lisp_poly_frame(stack->frame);
+       DBG("pop frame %d\n", OFFSET(ao_lisp_frame_current));
+       formals_tail = 0;
+
+       /* Recompute the tail of the formals list */
+       if (formals) {
+               struct ao_lisp_cons *formal;
+               for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr));
+               formals_tail = formal;
+       }
+       stack = ao_lisp_poly_stack(stack->next);
+}
+
+static void
+ao_lisp_stack_clear(void)
+{
+       stack = 0;
+       actuals = formals = formals_tail = 0;
+       cond = 0;
+       ao_lisp_frame_current = 0;
+}
+
+
+static ao_poly
+func_type(ao_poly func)
+{
+       struct ao_lisp_cons     *cons;
+       struct ao_lisp_cons     *args;
+       int                     f;
+
+       DBG("func type "); DBG_POLY(func); DBG("\n");
+       if (func == AO_LISP_NIL)
+               return ao_lisp_error(AO_LISP_INVALID, "func is nil");
+       if (ao_lisp_poly_type(func) != AO_LISP_CONS)
+               return ao_lisp_error(AO_LISP_INVALID, "func is not list");
+       cons = ao_lisp_poly_cons(func);
+       if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3))
+               return AO_LISP_NIL;
+       if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0))
+               return AO_LISP_NIL;
+       if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1))
+               return AO_LISP_NIL;
+       args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1));
+       f = 0;
+       while (args) {
+               if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) {
+                       return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f);
+               }
+               args = ao_lisp_poly_cons(args->cdr);
+               f++;
+       }
+       return ao_lisp_arg(cons, 0);
+}
+
+static int
+ao_lisp_cons_length(struct ao_lisp_cons *cons)
+{
+       int     len = 0;
+       while (cons) {
+               len++;
+               cons = ao_lisp_poly_cons(cons->cdr);
+       }
+       return len;
+}
+
+static ao_poly
+ao_lisp_lambda(struct ao_lisp_cons *cons)
+{
+       ao_poly                 type;
+       struct ao_lisp_cons     *lambda;
+       struct ao_lisp_cons     *args;
+       int                     args_wanted;
+       int                     args_provided;
+
+       lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0));
+       DBG("lambda "); DBG_CONS(lambda); DBG("\n");
+       type = ao_lisp_arg(lambda, 0);
+       args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1));
+
+       args_wanted = ao_lisp_cons_length(args);
+
+       /* Create a frame to hold the variables
+        */
+       if (type == _ao_lisp_atom_lambda)
+               args_provided = ao_lisp_cons_length(cons) - 1;
+       else
+               args_provided = 1;
+       if (args_wanted != args_provided)
+               return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided);
+       next_frame = ao_lisp_frame_new(args_wanted, 0);
+       DBG("new frame %d\n", OFFSET(next_frame));
+       switch (type) {
+       case _ao_lisp_atom_lambda: {
+               int                     f;
+               struct ao_lisp_cons     *vals = ao_lisp_poly_cons(cons->cdr);
+
+               for (f = 0; f < args_wanted; f++) {
+                       next_frame->vals[f].atom = args->car;
+                       next_frame->vals[f].val = vals->car;
+                       args = ao_lisp_poly_cons(args->cdr);
+                       vals = ao_lisp_poly_cons(vals->cdr);
+               }
+               break;
+       }
+       case _ao_lisp_atom_lexpr:
+       case _ao_lisp_atom_nlambda:
+               next_frame->vals[0].atom = args->car;
+               next_frame->vals[0].val = cons->cdr;
+               break;
+       case _ao_lisp_atom_macro:
+               next_frame->vals[0].atom = args->car;
+               next_frame->vals[0].val = ao_lisp_cons_poly(cons);
+               break;
+       }
+       return ao_lisp_arg(lambda, 2);
+}
+
 ao_poly
 ao_lisp_eval(ao_poly v)
 {
@@ -48,7 +254,7 @@ ao_lisp_eval(ao_poly v)
 
        if (!been_here) {
                been_here = 1;
-               ao_lisp_root_add(&ao_lisp_cons_type, &stack);
+               ao_lisp_root_add(&ao_lisp_stack_type, &stack);
                ao_lisp_root_add(&ao_lisp_cons_type, &actuals);
                ao_lisp_root_add(&ao_lisp_cons_type, &formals);
                ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail);
@@ -57,29 +263,43 @@ ao_lisp_eval(ao_poly v)
        actuals = 0;
        formals = 0;
        formals_tail = 0;
+       cond = 0;
        for (;;) {
 
        restart:
+               if (cond) {
+                       if (cond->car == AO_LISP_NIL) {
+                               cond = AO_LISP_NIL;
+                               v = AO_LISP_NIL;
+                       } else {
+                               if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) {
+                                       ao_lisp_error(AO_LISP_INVALID, "malformed cond");
+                                       goto bail;
+                               }
+                               v = ao_lisp_poly_cons(cond->car)->car;
+                       }
+               }
+
                /* Build stack frames for each list */
                while (ao_lisp_poly_type(v) == AO_LISP_CONS) {
                        if (v == AO_LISP_NIL)
                                break;
 
-                       /* Push existing frame on the stack */
-                       if (cons++) {
-                               struct ao_lisp_cons *frame;
+                       /* Push existing bits on the stack */
+                       if (cons++)
+                               if (!ao_lisp_stack_push())
+                                       goto bail;
 
-                               frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals);
-                               stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack);
-                       }
                        actuals = ao_lisp_poly_cons(v);
                        formals = NULL;
                        formals_tail = NULL;
+                       cond = NULL;
+
                        v = actuals->car;
 
-                       DBG("start: stack"); DBG_CONS(stack); DBG("\n");
-                       DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
-                       DBG("start: formals"); DBG_CONS(formals); DBG("\n");
+//                     DBG("start: stack"); DBG_CONS(stack); DBG("\n");
+//                     DBG("start: actuals"); DBG_CONS(actuals); DBG("\n");
+//                     DBG("start: formals"); DBG_CONS(formals); DBG("\n");
                }
 
                /* Evaluate primitive types */
@@ -95,19 +315,19 @@ ao_lisp_eval(ao_poly v)
                        break;
                }
 
-               if (!cons)
-                       break;
-
-               for (;;) {
+               while (cons) {
                        DBG("add formal: "); DBG_POLY(v); DBG("\n");
 
+                       /* We've processed the first element of the list, go check
+                        * what kind of function we've got
+                        */
                        if (formals == NULL) {
                                if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
                                        struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
                                        switch (b->args) {
                                        case AO_LISP_NLAMBDA:
-                                               v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
-                                               goto done_eval;
+                                               formals = actuals;
+                                               goto eval;
 
                                        case AO_LISP_MACRO:
                                                v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr));
@@ -115,15 +335,28 @@ ao_lisp_eval(ao_poly v)
                                                DBG(" -> "); DBG_POLY(v);
                                                DBG("\n");
                                                if (ao_lisp_poly_type(v) != AO_LISP_CONS) {
-                                                       ao_lisp_exception |= AO_LISP_INVALID;
-                                                       return AO_LISP_NIL;
+                                                       ao_lisp_error(AO_LISP_INVALID, "macro didn't return list");
+                                                       goto bail;
                                                }
-
                                                /* Reset frame to the new list */
                                                actuals = ao_lisp_poly_cons(v);
                                                v = actuals->car;
                                                goto restart;
                                        }
+                               } else {
+                                       switch (func_type(v)) {
+                                       case _ao_lisp_atom_lambda:
+                                       case _ao_lisp_atom_lexpr:
+                                               break;
+                                       case _ao_lisp_atom_nlambda:
+                                               formals = actuals;
+                                               goto eval;
+                                       case _ao_lisp_atom_macro:
+                                               break;
+                                       default:
+                                               ao_lisp_error(AO_LISP_INVALID, "operator is not a function");
+                                               goto bail;
+                                       }
                                }
                        }
 
@@ -150,6 +383,8 @@ ao_lisp_eval(ao_poly v)
 
                        v = formals->car;
 
+               eval:
+
                        /* Evaluate the resulting list */
                        if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) {
                                struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v);
@@ -161,41 +396,54 @@ ao_lisp_eval(ao_poly v)
                                DBG(" -> ");
                                DBG_POLY(v);
                                DBG ("\n");
+                               if (ao_lisp_exception)
+                                       goto bail;
+
+                               if (cond)
+                                       goto restart;
                        } else {
-                               ao_lisp_exception |= AO_LISP_INVALID;
+                               v = ao_lisp_lambda(formals);
+                               if (ao_lisp_exception)
+                                       goto bail;
                        }
-                       if (ao_lisp_exception)
-                               return AO_LISP_NIL;
-               done_eval:
-                       if (--cons) {
-                               struct ao_lisp_cons     *frame;
-
-                               /* Pop the previous frame off the stack */
-                               frame = ao_lisp_poly_cons(stack->car);
-                               actuals = ao_lisp_poly_cons(frame->car);
-                               formals = ao_lisp_poly_cons(frame->cdr);
-                               formals_tail = NULL;
-
-                               /* Recompute the tail of the formals list */
-                               if (formals) {
-                                       for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr));
-                                       formals_tail = formal;
-                               }
 
-                               stack = ao_lisp_poly_cons(stack->cdr);
-                               DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
-                               DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
-                               DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
+                       --cons;
+                       if (cons) {
+                               ao_lisp_stack_pop();
+//                             DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n");
+//                             DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n");
+//                             DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n");
                        } else {
                                actuals = 0;
                                formals = 0;
                                formals_tail = 0;
-                               DBG("done func\n");
-                               break;
+                               ao_lisp_frame_current = 0;
+                       }
+                       if (next_frame) {
+                               ao_lisp_frame_current = next_frame;
+                               DBG("next frame %d\n", OFFSET(next_frame));
+                               next_frame = 0;
+                               goto restart;
+                       }
+                       if (cond) {
+                               if (v) {
+                                       v = ao_lisp_poly_cons(cond->car)->cdr;
+                                       if (v != AO_LISP_NIL) {
+                                               v = ao_lisp_poly_cons(v)->car;
+                                               goto restart;
+                                       }
+                               } else {
+                                       cond = ao_lisp_poly_cons(cond->cdr);
+                                       goto restart;
+                               }
                        }
                }
                if (!cons)
                        break;
        }
+       DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current));
        return v;
+bail:
+       ao_lisp_stack_clear();
+       return AO_LISP_NIL;
 }
index 5aa50f6b0661738ccf4fcc9f9b6c849c0f0ff85f..1853f6d76a0bfd284be541aa27127ea4729da067 100644 (file)
@@ -95,7 +95,7 @@ const struct ao_lisp_type ao_lisp_frame_type = {
        .move = frame_move
 };
 
-static ao_poly *
+ao_poly *
 ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom)
 {
        int f;
index 6b6039795e7fe2fce6c456f865a9ff6cd288cd5f..9c2ea74cdccf811e2514b49cdfa0b08638eae62f 100644 (file)
@@ -39,6 +39,7 @@ struct builtin_func funcs[] = {
        "quote",        AO_LISP_NLAMBDA,builtin_quote,
        "set",          AO_LISP_LEXPR,  builtin_set,
        "setq",         AO_LISP_MACRO,  builtin_setq,
+       "cond",         AO_LISP_NLAMBDA,builtin_cond,
        "print",        AO_LISP_LEXPR,  builtin_print,
        "+",            AO_LISP_LEXPR,  builtin_plus,
        "-",            AO_LISP_LEXPR,  builtin_minus,
@@ -47,8 +48,25 @@ struct builtin_func funcs[] = {
        "%",            AO_LISP_LEXPR,  builtin_mod
 };
 
+ao_poly
+ao_lisp_set_cond(struct ao_lisp_cons *c)
+{
+       (void) c;
+       return AO_LISP_NIL;
+}
+
 #define N_FUNC (sizeof funcs / sizeof funcs[0])
 
+/* Syntactic atoms */
+char *atoms[] = {
+       "lambda",
+       "nlambda",
+       "lexpr",
+       "macro"
+};
+
+#define N_ATOM (sizeof atoms / sizeof atoms[0])
+
 struct ao_lisp_frame   *globals;
 
 static int
@@ -65,9 +83,10 @@ is_atom(int offset)
 int
 main(int argc, char **argv)
 {
-       int     f, o;
+       int     f, o, i;
        ao_poly atom, val;
        struct ao_lisp_atom     *a;
+       struct ao_lisp_builtin  *b;
        int     in_atom;
 
        printf("/*\n");
@@ -75,11 +94,15 @@ main(int argc, char **argv)
        ao_lisp_root_add(&ao_lisp_frame_type, &globals);
        globals = ao_lisp_frame_new(0, 0);
        for (f = 0; f < N_FUNC; f++) {
-               struct ao_lisp_builtin  *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args);
-               struct ao_lisp_atom     *a = ao_lisp_atom_intern(funcs[f].name);
+               b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args);
+               a = ao_lisp_atom_intern(funcs[f].name);
                globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b));
        }
 
+       /* atoms for syntax */
+       for (i = 0; i < N_ATOM; i++)
+               (void) ao_lisp_atom_intern(atoms[i]);
+
        /* boolean constants */
        a = ao_lisp_atom_intern("nil");
        globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL);
index a1f9fa1f4b9be8834a459a7598d4a82e8d701eef..d780186a2768e3fc633f22ca8174e352cee5d4ff 100644 (file)
@@ -25,12 +25,6 @@ ao_lisp_read_eval_print(void)
 //             printf ("in: "); ao_lisp_poly_print(in); printf("\n");
                out = ao_lisp_eval(in);
                if (ao_lisp_exception) {
-                       if (ao_lisp_exception & AO_LISP_OOM)
-                               printf("out of memory\n");
-                       if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO)
-                               printf("divide by zero\n");
-                       if (ao_lisp_exception & AO_LISP_INVALID)
-                               printf("invalid operation\n");
                        ao_lisp_exception = 0;
                } else {
                        ao_lisp_poly_print(out);
index 1b7e0bb093f57ab031fa4a5a4c5f95e81e094eef..388e581c5394b4165ffd7fd285319106206b5a53 100644 (file)
@@ -46,6 +46,7 @@ ALTOS_SRC = \
        ao_lisp_read.c \
        ao_lisp_rep.c \
        ao_lisp_frame.c \
+       ao_lisp_error.c \
        ao_exti_stm.c
 
 PRODUCT=Nucleo-32
index 762001761396c50cf635cd11ffdbc7f7997d61ca..65de89edd014cfa0e2c18a79fa267793ff8d08da 100644 (file)
@@ -24,6 +24,8 @@
 #define LED_PIN_GREEN  3
 #define AO_LED_GREEN   (1 << LED_PIN_GREEN)
 #define AO_LED_PANIC   AO_LED_GREEN
+#define AO_CMD_LEN     128
+#define AO_LISP_POOL   2048
 
 #define LEDS_AVAILABLE (AO_LED_GREEN)
 
index bd19516180986f42e58981a1d1c57639c5af15e4..8d617eeaf9c7150e3a55afa6d98a66236861a760 100644 (file)
@@ -93,7 +93,8 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h
 
 AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o  ao_lisp_cons.o ao_lisp_string.o \
        ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \
-       ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o
+       ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \
+       ao_lisp_error.o
 
 ao_lisp_test: $(AO_LISP_OBJS)
        cc $(CFLAGS) -o $@ $(AO_LISP_OBJS)
index e303869f411fb05e819f489096538e8b4b89b65e..8bc677daa5a54e947f4c86c69caa704e0f4f949d 100644 (file)
 #include "ao_lisp.h"
 #include <stdio.h>
 
+#if 0
 static struct ao_lisp_cons     *list;
 static char                    *string;
+#endif
 
 int
 main (int argc, char **argv)
 {
+#if 0
        int                     i, j;
-       struct ao_lisp_atom     *atom;
 
+       struct ao_lisp_atom     *atom;
        ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list);
        ao_lisp_root_add(&ao_lisp_string_type, (void **) &string);
 
@@ -47,7 +50,8 @@ main (int argc, char **argv)
                ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom)));
                printf("\n");
        }
-#if 1
+#endif
+#if 0
        list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")),
                                 ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")),
                                                                                       ao_lisp_cons_cons(ao_lisp_int_poly(3),
@@ -58,7 +62,8 @@ main (int argc, char **argv)
        printf ("\n");
        ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list)));
        printf ("\n");
-
+#endif
+#if 1
        ao_lisp_read_eval_print();
 #endif
 }