From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: [PATCH] altos: Add lambda support to lisp Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 51 ++++- src/lisp/ao_lisp_atom.c | 62 ++++-- src/lisp/ao_lisp_builtin.c | 123 ++++++------ src/lisp/ao_lisp_const.lisp | 3 + src/lisp/ao_lisp_error.c | 29 +++ src/lisp/ao_lisp_eval.c | 368 ++++++++++++++++++++++++++++------ src/lisp/ao_lisp_frame.c | 2 +- src/lisp/ao_lisp_make_const.c | 29 ++- src/lisp/ao_lisp_rep.c | 6 - src/nucleao-32/Makefile | 1 + src/nucleao-32/ao_pins.h | 2 + src/test/Makefile | 3 +- src/test/ao_lisp_test.c | 11 +- 14 files changed, 528 insertions(+), 165 deletions(-) create mode 100644 src/lisp/ao_lisp_error.c diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 9e2fb58c..be19b432 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -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) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 98e99acb..9a5cc63e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -32,11 +32,22 @@ 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_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e5d28c3b..ea04741e 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -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; } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 8c481793..2976bc95 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -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, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index aa356d45..5ee15899 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -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 index 00000000..ea8111d9 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,29 @@ +/* + * Copyright © 2016 Keith Packard + * + * 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 + +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; +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 6eef1f23..803f1e2e 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,32 +14,238 @@ #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; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 5aa50f6b..1853f6d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -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; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6b603979..9c2ea74c 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -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); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index a1f9fa1f..d780186a 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -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); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 1b7e0bb0..388e581c 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -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 diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 76200176..65de89ed 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -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) diff --git a/src/test/Makefile b/src/test/Makefile index bd195161..8d617eea 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -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) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index e303869f..8bc677da 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -15,15 +15,18 @@ #include "ao_lisp.h" #include +#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 } -- 2.30.2