From d2408e72d1e0d3459918601712b09860ab17e200 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 1 Nov 2016 21:14:45 -0700 Subject: altos/lisp: Change lisp objects to use ao_poly everywhere. Add const This makes all lisp objects use 16-bit ints for references so we can hold more stuff in small amounts of memory. Also adds a separate constant pool of lisp objects for builtins, initial atoms and constant lisp code. Now builds (and runs!) on the nucleo-32 boards. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_rep.c | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 src/lisp/ao_lisp_rep.c (limited to 'src/lisp/ao_lisp_rep.c') diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c new file mode 100644 index 00000000..d26d270c --- /dev/null +++ b/src/lisp/ao_lisp_rep.c @@ -0,0 +1,40 @@ +/* + * 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" + +ao_poly +ao_lisp_read_eval_print(void) +{ + ao_poly in, out = AO_LISP_NIL; + for(;;) { + in = ao_lisp_read(); + if (!in) + break; + 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); + putchar ('\n'); + } + } + return out; +} -- cgit v1.2.3 From 9e1a787f8828fb7b750ad3310c89a89536ea5286 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 14:18:54 -0700 Subject: altos/lisp: add set/setq and ' in reader Along with other small fixes Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 ++++ src/lisp/ao_lisp_builtin.c | 76 ++++++++++++++++++++++++++---- src/lisp/ao_lisp_eval.c | 13 ++++-- src/lisp/ao_lisp_make_const.c | 23 ++++++++- src/lisp/ao_lisp_read.c | 105 +++++++++++++++++++++++++++++------------- src/lisp/ao_lisp_rep.c | 1 + 6 files changed, 183 insertions(+), 43 deletions(-) (limited to 'src/lisp/ao_lisp_rep.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 4fac861b..d4108662 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -27,6 +27,7 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) #else #include "ao_lisp_const.h" #endif @@ -62,6 +63,11 @@ extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +static inline int +ao_lisp_is_const(ao_poly poly) { + return poly & AO_LISP_CONST; +} + static inline void * ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) @@ -128,6 +134,8 @@ enum ao_lisp_builtin_id { builtin_cdr, builtin_cons, builtin_quote, + builtin_set, + builtin_setq, builtin_print, builtin_plus, builtin_minus, diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e6d55797..63fb69fd 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -21,20 +21,46 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } +static int check_argc(struct ao_lisp_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_lisp_poly_cons(cons->cdr); + } + if (argc < min || argc > max) { + ao_lisp_exception |= AO_LISP_INVALID; + return 0; + } + return 1; +} + +static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car; + + /* find the desired arg */ + while (argc--) + 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; +} + enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!check_argc(cons, 1, 1)) return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { ao_lisp_exception |= AO_LISP_INVALID; return AO_LISP_NIL; } @@ -91,6 +117,38 @@ ao_lisp_quote(struct ao_lisp_cons *cons) return cons->car; } +ao_poly +ao_lisp_set(struct ao_lisp_cons *cons) +{ + ao_poly atom, val; + if (!check_argc(cons, 2, 2)) + return AO_LISP_NIL; + if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + + atom = cons->car; + val = ao_lisp_poly_cons(cons->cdr)->car; + if (ao_lisp_is_const(atom)) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + ao_lisp_poly_atom(atom)->val = val; + return val; +} + +ao_poly +ao_lisp_setq(struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *expand = 0; + if (!check_argc(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, + ao_lisp_cons_cons(cons->car, NULL))), + ao_lisp_poly_cons(cons->cdr))); + return ao_lisp_cons_poly(expand); +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -196,6 +254,8 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, [builtin_quote] = ao_lisp_quote, + [builtin_set] = ao_lisp_set, + [builtin_setq] = ao_lisp_setq, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index b13d4681..2374fdb2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -111,6 +111,9 @@ ao_lisp_eval(ao_poly v) case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); + 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; @@ -160,8 +163,9 @@ ao_lisp_eval(ao_poly v) DBG ("\n"); } else { ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; } + if (ao_lisp_exception) + return AO_LISP_NIL; done_eval: if (--cons) { struct ao_lisp_cons *frame; @@ -170,10 +174,13 @@ ao_lisp_eval(ao_poly v) 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 */ - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; + 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"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 21e000bf..8d3e03a9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static struct ao_lisp_builtin * ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { @@ -36,6 +37,8 @@ struct builtin_func funcs[] = { "cdr", AO_LISP_LEXPR, builtin_cdr, "cons", AO_LISP_LEXPR, builtin_cons, "quote", AO_LISP_NLAMBDA,builtin_quote, + "set", AO_LISP_LEXPR, builtin_set, + "setq", AO_LISP_MACRO, builtin_setq, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -51,6 +54,7 @@ main(int argc, char **argv) { int f, o; ao_poly atom, val; + struct ao_lisp_atom *a; for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); @@ -76,14 +80,31 @@ main(int argc, char **argv) printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { + char *n = a->name, c; + printf ("#define _ao_lisp_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + printf("%c", c); + else + printf("%02x", c); + } + printf(" 0x%04x\n", ao_lisp_atom_poly(a)); + } printf("#ifdef AO_LISP_CONST_BITS\n"); printf("const uint8_t ao_lisp_const[] = {"); for (o = 0; o < ao_lisp_top; o++) { + uint8_t c; if ((o & 0xf) == 0) printf("\n\t"); else printf(" "); - printf("0x%02x,", ao_lisp_const[o]); + c = ao_lisp_const[o]; + if (' ' < c && c <= '~' && c != '\'') + printf (" '%c',", c); + else + printf("0x%02x,", c); } printf("\n};\n"); printf("#endif /* AO_LISP_CONST_BITS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ea98b976..8fc134e5 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -375,12 +375,45 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_poly -read_item(void) +static int +push_read_stack(int cons, int in_quote) +{ + if (cons) { + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), + ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), + read_stack)); + if (!read_stack) + return 0; + } + read_cons = NULL; + read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int in_quote = 0; + if (cons) { + read_cons = ao_lisp_poly_cons(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + in_quote = ao_lisp_poly_int(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + for (read_cons_tail = read_cons; + read_cons_tail && read_cons_tail->cdr; + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) + ; + } + return in_quote; +} + +ao_poly +ao_lisp_read(void) { struct ao_lisp_atom *atom; char *string; int cons; + int in_quote; ao_poly v; if (!been_here) { @@ -388,15 +421,17 @@ read_item(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); } + parse_token = lex(); cons = 0; + in_quote = 0; read_cons = read_cons_tail = read_stack = 0; for (;;) { while (parse_token == OPEN) { - if (cons++) - read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); - read_cons = NULL; - read_cons_tail = NULL; + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 0; parse_token = lex(); } @@ -422,40 +457,48 @@ read_item(void) else v = AO_LISP_NIL; break; + case QUOTE: + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 1; + v = _ao_lisp_atom_quote; + break; case CLOSE: - if (cons) - v = ao_lisp_cons_poly(read_cons); - else + if (!cons) { v = AO_LISP_NIL; - if (--cons) { - read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - for (read_cons_tail = read_cons; - read_cons_tail && read_cons_tail->cdr; - read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) - ; + break; } + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); break; } - if (!cons) - break; + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); + if (!read) + return AO_LISP_NIL; + + if (read_cons_tail) + read_cons_tail->cdr = ao_lisp_cons_poly(read); + else + read_cons = read; + read_cons_tail = read; + + if (!in_quote || !read_cons->cdr) + break; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (read_cons_tail) - read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - read_cons = read; - read_cons_tail = read; + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); + } parse_token = lex(); } return v; } - -ao_poly -ao_lisp_read(void) -{ - parse_token = lex(); - return read_item(); -} diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index d26d270c..a1f9fa1f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -22,6 +22,7 @@ ao_lisp_read_eval_print(void) in = ao_lisp_read(); if (!in) break; +// 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) -- cgit v1.2.3 From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: 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 (limited to 'src/lisp/ao_lisp_rep.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 } -- cgit v1.2.3 From 92cdc0cf0e80c1ff3f31cce20fc2b9bda86e3638 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 10 Nov 2016 23:25:56 -0800 Subject: altos/lisp: Make read() return eof atom on end of file Also make it an exception to hit eof in the middle of an sexpr. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 ++ src/lisp/ao_lisp_read.c | 18 ++++++++++++++---- src/lisp/ao_lisp_rep.c | 3 +-- 3 files changed, 17 insertions(+), 6 deletions(-) (limited to 'src/lisp/ao_lisp_rep.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d265ea7b..6122a2ed 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -42,6 +42,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_delay _atom("delay") #define _ao_lisp_atom_eval _atom("eval") #define _ao_lisp_atom_read _atom("read") +#define _ao_lisp_atom_eof _atom("eof") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -76,6 +77,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 +#define AO_LISP_EOF 0x10 extern uint8_t ao_lisp_exception; diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 3a2ef7f1..7a5751ce 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -12,6 +12,7 @@ * General Public License for more details. */ +#define DBG_EVAL 0 #include "ao_lisp.h" #include "ao_lisp_read.h" @@ -270,7 +271,7 @@ lex(void) for (;;) { c = lexc(); if (lex_class & ENDOFFILE) - return AO_LISP_NIL; + return END; if (lex_class & WHITE) continue; @@ -278,7 +279,7 @@ lex(void) if (lex_class & COMMENT) { while ((c = lexc()) != '\n') { if (lex_class & ENDOFFILE) - return AO_LISP_NIL; + return END; } continue; } @@ -364,6 +365,8 @@ static struct ao_lisp_cons *read_stack; static int push_read_stack(int cons, int in_quote) { + DBGI("push read stack %p %d\n", read_cons, in_quote); + DBG_IN(); if (cons) { read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), @@ -394,6 +397,8 @@ pop_read_stack(int cons) read_cons_tail = 0; read_stack = 0; } + DBG_OUT(); + DBGI("pop read stack %p %d\n", read_cons, in_quote); return in_quote; } @@ -413,6 +418,7 @@ ao_lisp_read(void) been_here = 1; } parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; in_quote = 0; @@ -424,12 +430,15 @@ ao_lisp_read(void) cons++; in_quote = 0; parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); } switch (parse_token) { - case ENDOFFILE: + case END: default: - v = AO_LISP_NIL; + if (cons) + ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); + return _ao_lisp_atom_eof; break; case NAME: atom = ao_lisp_atom_intern(token_string); @@ -490,6 +499,7 @@ ao_lisp_read(void) } parse_token = lex(); + DBGI("token %d (%s)\n", parse_token, token_string); } return v; } diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index d780186a..ef7dbaf2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -20,9 +20,8 @@ ao_lisp_read_eval_print(void) ao_poly in, out = AO_LISP_NIL; for(;;) { in = ao_lisp_read(); - if (!in) + if (in == _ao_lisp_atom_eof) break; -// printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { ao_lisp_exception = 0; -- cgit v1.2.3 From 9e80b8bd10433ecc6ebe7c295e16b62b3883987d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 9 Apr 2017 12:55:34 -0700 Subject: altos: Escape lisp REP loop with () input Provide a way to get out of a lisp read-eval-print loop that can be easily input from the keyboard. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_rep.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/lisp/ao_lisp_rep.c') diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index ef7dbaf2..3be95d44 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -20,7 +20,7 @@ ao_lisp_read_eval_print(void) ao_poly in, out = AO_LISP_NIL; for(;;) { in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) + if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { -- cgit v1.2.3