From 56d46ceaa1413415f25e47e81036426132f99924 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 31 Oct 2016 16:43:44 -0700 Subject: Add first lisp bits Signed-off-by: Keith Packard --- src/lisp/ao_lisp_poly.c | 132 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 132 insertions(+) create mode 100644 src/lisp/ao_lisp_poly.c (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c new file mode 100644 index 00000000..1855d945 --- /dev/null +++ b/src/lisp/ao_lisp_poly.c @@ -0,0 +1,132 @@ +/* + * 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" + +enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; + +ao_lisp_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) +{ + ao_lisp_poly ret = AO_LISP_NIL; + + while (cons) { + ao_lisp_poly car = cons->car; + uint8_t rt = ao_lisp_poly_type(ret); + uint8_t ct = ao_lisp_poly_type(car); + + cons = cons->cdr; + + if (rt == AO_LISP_NIL) + ret = car; + + else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + int r = ao_lisp_poly_int(ret); + int c = ao_lisp_poly_int(car); + + switch(op) { + case math_plus: + r += c; + break; + case math_minus: + r -= c; + break; + case math_times: + r *= c; + break; + case math_divide: + if (c == 0) + return AO_LISP_NIL; + r /= c; + break; + case math_mod: + if (c == 0) + return AO_LISP_NIL; + r %= c; + break; + } + ret = ao_lisp_int_poly(r); + } + + 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 { + /* XXX exception */ + return AO_LISP_NIL; + } + } + return ret; +} + +ao_lisp_poly +ao_lisp_plus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_plus); +} + +ao_lisp_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_minus); +} + +ao_lisp_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_times); +} + +ao_lisp_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_divide); +} + +ao_lisp_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_mod); +} + +static const struct ao_lisp_builtin builtin_plus = { + .type = AO_LISP_BUILTIN, + .func = ao_lisp_plus, + .name = "+" +}; + +static const struct ao_lisp_atom atom_plus = { + .type = AO_LISP_ATOM, + .val = AO_LISP_OTHER_POLY(&builtin_plus), + .next = AO_LISP_ATOM_CONST, + .name = "plus" +}; + +/* +static const struct ao_lisp_builtin builtin_minus = { + .type = AO_LISP_BUILTIN, + .func = ao_lisp_minus +}; + +static const struct ao_lisp_builtin builtin_times = { + .type = AO_LISP_BUILTIN, + .func = ao_lisp_times +}; + +*/ + +const struct ao_lisp_atom const *ao_lisp_builtins[] = { + &atom_plus, + 0 +}; -- cgit v1.2.3 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/.gitignore | 2 + src/lisp/Makefile | 32 +++++ src/lisp/ao_lisp.h | 238 ++++++++++++++++++++++----------- src/lisp/ao_lisp_atom.c | 43 +++--- src/lisp/ao_lisp_builtin.c | 189 +++++++++++++++++++++++++- src/lisp/ao_lisp_cons.c | 19 +-- src/lisp/ao_lisp_const.lisp | 1 + src/lisp/ao_lisp_eval.c | 57 ++++++-- src/lisp/ao_lisp_int.c | 3 +- src/lisp/ao_lisp_make_const.c | 90 +++++++++++++ src/lisp/ao_lisp_mem.c | 41 ++++-- src/lisp/ao_lisp_poly.c | 89 +----------- src/lisp/ao_lisp_prim.c | 40 +++--- src/lisp/ao_lisp_read.c | 31 +++-- src/lisp/ao_lisp_rep.c | 40 ++++++ src/lisp/ao_lisp_string.c | 6 +- src/nucleao-32/.gitignore | 2 + src/nucleao-32/Makefile | 11 ++ src/nucleao-32/ao_nucleo.c | 7 + src/nucleao-32/flash-loader/.gitignore | 2 + src/test/Makefile | 8 +- src/test/ao_lisp_test.c | 40 +++--- 22 files changed, 714 insertions(+), 277 deletions(-) create mode 100644 src/lisp/.gitignore create mode 100644 src/lisp/Makefile create mode 100644 src/lisp/ao_lisp_const.lisp create mode 100644 src/lisp/ao_lisp_make_const.c create mode 100644 src/lisp/ao_lisp_rep.c create mode 100644 src/nucleao-32/.gitignore create mode 100644 src/nucleao-32/flash-loader/.gitignore (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore new file mode 100644 index 00000000..76a555ea --- /dev/null +++ b/src/lisp/.gitignore @@ -0,0 +1,2 @@ +ao_lisp_make_const +ao_lisp_const.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile new file mode 100644 index 00000000..e8c3c02c --- /dev/null +++ b/src/lisp/Makefile @@ -0,0 +1,32 @@ +all: ao_lisp_const.h + +clean: + rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + +ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const + ./ao_lisp_make_const < ao_lisp_const.lisp > $@ + +SRCS=\ + ao_lisp_make_const.c\ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_poly.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g + +HDRS=\ + ao_lisp.h \ + ao_lisp_read.h + +ao_lisp_make_const: $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) + +$(OBJS): $(HDRS) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 6667dcc2..4fac861b 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,78 +15,158 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ +#if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) +#include +#define AO_LISP_ALTOS 1 +#endif + #include #include #include +#ifdef AO_LISP_MAKE_CONST +#define AO_LISP_POOL_CONST 16384 +extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#else +#include "ao_lisp_const.h" +#endif + +/* Primitive types */ +#define AO_LISP_CONS 0 +#define AO_LISP_INT 1 +#define AO_LISP_STRING 2 +#define AO_LISP_OTHER 3 -# define AO_LISP_CONS 0 -# define AO_LISP_INT 1 -# define AO_LISP_STRING 2 -# define AO_LISP_OTHER 3 +#define AO_LISP_TYPE_MASK 0x0003 +#define AO_LISP_TYPE_SHIFT 2 +#define AO_LISP_REF_MASK 0x7ffc +#define AO_LISP_CONST 0x8000 -# define AO_LISP_ATOM 4 -# define AO_LISP_BUILTIN 5 +/* These have a type value at the start of the struct */ +#define AO_LISP_ATOM 4 +#define AO_LISP_BUILTIN 5 +#define AO_LISP_NUM_TYPE 6 -# define AO_LISP_NIL 0 +#define AO_LISP_NIL 0 #define AO_LISP_POOL 1024 -#define AO_LISP_ROOT 16 -static inline void *ao_lisp_set_ref(void *addr) { - return (void *) ((intptr_t)addr | 1); +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +extern uint16_t ao_lisp_top; + +#define AO_LISP_OOM 0x01 +#define AO_LISP_DIVIDE_BY_ZERO 0x02 +#define AO_LISP_INVALID 0x04 + +extern uint8_t ao_lisp_exception; + +typedef uint16_t ao_poly; + +static inline void * +ao_lisp_ref(ao_poly poly) { + if (poly == AO_LISP_NIL) + return NULL; + if (poly & AO_LISP_CONST) + return (void *) ((ao_lisp_const - 4) + (poly & AO_LISP_REF_MASK)); + else + return (void *) ((ao_lisp_pool - 4) + (poly & AO_LISP_REF_MASK)); } -static inline void *ao_lisp_clear_ref(void *addr) { - return (void *) ((intptr_t)addr & ~1); +static inline ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (addr == NULL) + return AO_LISP_NIL; + if (ao_lisp_pool <= a && a < ao_lisp_pool + AO_LISP_POOL) + return (a - (ao_lisp_pool - 4)) | type; + else if (ao_lisp_const <= a && a <= ao_lisp_const + AO_LISP_POOL_CONST) + return AO_LISP_CONST | (a - (ao_lisp_const - 4)) | type; + else { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } } -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; +#define AO_LISP_POLY(addr, type) (((ao_lisp_pool <= ((uint8_t *) (a)) && \ + ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) ? \ + ((uint8_t *) (a) - (ao_lisp_pool - 4)) : \ + (((uint8_t *) (a) - (ao_lisp_const - 4)) | AO_LISP_POOL_CONST)) | \ + (type)) -struct ao_lisp_mem_type { +struct ao_lisp_type { void (*mark)(void *addr); int (*size)(void *addr); void (*move)(void *addr); }; -typedef intptr_t ao_lisp_poly; - struct ao_lisp_cons { - ao_lisp_poly car; - struct ao_lisp_cons *cdr; + ao_poly car; + ao_poly cdr; }; struct ao_lisp_atom { - uint8_t type; - ao_lisp_poly val; - struct ao_lisp_atom *next; - char name[]; + uint8_t type; + uint8_t pad[1]; + ao_poly val; + ao_poly next; + char name[]; }; -#define AO_LISP_ATOM_CONST ((struct ao_lisp_atom *) (intptr_t) 1) - -extern const struct ao_lisp_atom *ao_lisp_builtins[]; +#define AO_LISP_LAMBDA 0 +#define AO_LISP_NLAMBDA 1 +#define AO_LISP_MACRO 2 +#define AO_LISP_LEXPR 3 struct ao_lisp_builtin { - uint8_t type; - ao_lisp_poly (*func)(struct ao_lisp_cons *cons); - char name[]; + uint8_t type; + uint8_t args; + uint16_t func; }; +enum ao_lisp_builtin_id { + builtin_car, + builtin_cdr, + builtin_cons, + builtin_quote, + builtin_print, + builtin_plus, + builtin_minus, + builtin_times, + builtin_divide, + builtin_mod, + builtin_last +}; + +typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); + +extern ao_lisp_func_t ao_lisp_builtins[]; + +static inline ao_lisp_func_t +ao_lisp_func(struct ao_lisp_builtin *b) +{ + return ao_lisp_builtins[b->func]; +} + static inline void * -ao_lisp_poly_other(ao_lisp_poly poly) { - return (void *) (poly - AO_LISP_OTHER); +ao_lisp_poly_other(ao_poly poly) { + return ao_lisp_ref(poly); } -static const inline ao_lisp_poly +static inline ao_poly ao_lisp_other_poly(const void *other) { - return (ao_lisp_poly) other + AO_LISP_OTHER; + return ao_lisp_poly(other, AO_LISP_OTHER); +} + +static inline int +ao_lisp_mem_round(int size) +{ + return (size + 3) & ~3; } -#define AO_LISP_OTHER_POLY(other) ((ao_lisp_poly)(other) + AO_LISP_OTHER) +#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) -static inline int ao_lisp_poly_type(ao_lisp_poly poly) { +static inline int ao_lisp_poly_type(ao_poly poly) { int type = poly & 3; if (type == AO_LISP_OTHER) return *((uint8_t *) ao_lisp_poly_other(poly)); @@ -94,75 +174,75 @@ static inline int ao_lisp_poly_type(ao_lisp_poly poly) { } static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_lisp_poly poly) +ao_lisp_poly_cons(ao_poly poly) { - return (struct ao_lisp_cons *) (poly - AO_LISP_CONS); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_cons_poly(struct ao_lisp_cons *cons) { - return (ao_lisp_poly) cons + AO_LISP_CONS; + return ao_lisp_poly(cons, AO_LISP_CONS); } static inline int -ao_lisp_poly_int(ao_lisp_poly poly) +ao_lisp_poly_int(ao_poly poly) { - return (int) (poly >> 2); + return (int) poly >> AO_LISP_TYPE_SHIFT; } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_lisp_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) + AO_LISP_INT; } static inline char * -ao_lisp_poly_string(ao_lisp_poly poly) +ao_lisp_poly_string(ao_poly poly) { - return (char *) (poly - AO_LISP_STRING); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly -ao_lisp_string_poly(char *s) { - return (ao_lisp_poly) s + AO_LISP_STRING; +static inline ao_poly +ao_lisp_string_poly(char *s) +{ + return ao_lisp_poly(s, AO_LISP_STRING); } static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_lisp_poly poly) +ao_lisp_poly_atom(ao_poly poly) { - return (struct ao_lisp_atom *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_atom_poly(struct ao_lisp_atom *a) { - return (ao_lisp_poly) a + AO_LISP_OTHER; + return ao_lisp_poly(a, AO_LISP_OTHER); } static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_lisp_poly poly) +ao_lisp_poly_builtin(ao_poly poly) { - return (struct ao_lisp_builtin *) (poly - AO_LISP_OTHER); + return ao_lisp_ref(poly); } -static inline ao_lisp_poly +static inline ao_poly ao_lisp_builtin_poly(struct ao_lisp_builtin *b) { - return (ao_lisp_poly) b + AO_LISP_OTHER; + return ao_lisp_poly(b, AO_LISP_OTHER); } /* memory functions */ - void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_mark(const struct ao_lisp_type *type, void *addr); /* returns 1 if the object was already marked */ int ao_lisp_mark_memory(void *addr, int size); void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_move(const struct ao_lisp_type *type, void *addr); /* returns NULL if the object was already moved */ void * @@ -172,22 +252,22 @@ void * ao_lisp_alloc(int size); int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr); +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); void ao_lisp_root_clear(void *addr); /* cons */ -extern const struct ao_lisp_mem_type ao_lisp_cons_type; +extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr); +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); void -ao_lisp_cons_print(struct ao_lisp_cons *cons); +ao_lisp_cons_print(ao_poly); /* string */ -extern const struct ao_lisp_mem_type ao_lisp_string_type; +extern const struct ao_lisp_type ao_lisp_string_type; char * ao_lisp_string_new(int len); @@ -199,44 +279,50 @@ char * ao_lisp_string_cat(char *a, char *b); void -ao_lisp_string_print(char *s); +ao_lisp_string_print(ao_poly s); /* atom */ -extern const struct ao_lisp_mem_type ao_lisp_atom_type; +extern const struct ao_lisp_type ao_lisp_atom_type; + +extern struct ao_lisp_atom *ao_lisp_atoms; void ao_lisp_atom_init(void); void -ao_lisp_atom_print(struct ao_lisp_atom *atom); +ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); /* int */ void -ao_lisp_int_print(int i); +ao_lisp_int_print(ao_poly i); /* prim */ -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p); +ao_poly +ao_lisp_poly_print(ao_poly p); void -ao_lisp_poly_mark(ao_lisp_poly p); +ao_lisp_poly_mark(ao_poly p); -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p); +ao_poly +ao_lisp_poly_move(ao_poly p); /* eval */ -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly p); +ao_poly +ao_lisp_eval(ao_poly p); /* builtin */ void -ao_lisp_builtin_print(struct ao_lisp_builtin *b); +ao_lisp_builtin_print(ao_poly b); /* read */ -ao_lisp_poly +ao_poly ao_lisp_read(void); +/* rep */ +ao_poly +ao_lisp_read_eval_print(void); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 65282142..aaa84b8d 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -34,12 +34,9 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { ao_lisp_poly_mark(atom->val); - atom = atom->next; + atom = ao_lisp_poly_atom(atom->next); if (!atom) break; if (ao_lisp_mark_memory(atom, atom_size(atom))) @@ -51,49 +48,50 @@ static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; - if (atom->next == AO_LISP_ATOM_CONST) - return; - for (;;) { struct ao_lisp_atom *next; atom->val = ao_lisp_poly_move(atom->val); - next = ao_lisp_move_memory(atom->next, atom_size(atom->next)); + next = ao_lisp_poly_atom(atom->next); + next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; - atom->next = next; + atom->next = ao_lisp_atom_poly(next); atom = next; } } -const struct ao_lisp_mem_type ao_lisp_atom_type = { +const struct ao_lisp_type ao_lisp_atom_type = { .mark = atom_mark, .size = atom_size, .move = atom_move, }; -struct ao_lisp_atom *atoms; +struct ao_lisp_atom *ao_lisp_atoms; struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; - int b; +// int b; - for (atom = atoms; atom; atom = atom->next) { + for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { + if (!strcmp(atom->name, name)) + return atom; + } +#ifdef ao_builtin_atoms + for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) return atom; } - for (b = 0; ao_lisp_builtins[b]; b++) - if (!strcmp(ao_lisp_builtins[b]->name, name)) - return (struct ao_lisp_atom *) ao_lisp_builtins[b]; - if (!atoms) - ao_lisp_root_add(&ao_lisp_atom_type, (void **) &atoms); +#endif + if (!ao_lisp_atoms) + ao_lisp_root_add(&ao_lisp_atom_type, (void **) &ao_lisp_atoms); atom = ao_lisp_alloc(name_size(name)); if (atom) { atom->type = AO_LISP_ATOM; - atom->next = atoms; - atoms = atom; + atom->next = ao_lisp_atom_poly(ao_lisp_atoms); + ao_lisp_atoms = atom; strcpy(atom->name, name); atom->val = AO_LISP_NIL; } @@ -101,7 +99,8 @@ ao_lisp_atom_intern(char *name) } void -ao_lisp_atom_print(struct ao_lisp_atom *a) +ao_lisp_atom_print(ao_poly a) { - fputs(a->name, stdout); + struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); + printf("%s", atom->name); } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 3752a2c8..e6d55797 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -15,7 +15,192 @@ #include "ao_lisp.h" void -ao_lisp_builtin_print(struct ao_lisp_builtin *b) +ao_lisp_builtin_print(ao_poly b) { - printf("[builtin %s]", b->name); + (void) b; + printf("[builtin]"); } + +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; + return AO_LISP_NIL; + } + if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + 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; + 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; + return AO_LISP_NIL; + } + return ao_lisp_poly_cons(cons->car)->cdr; +} + +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; + 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; + return AO_LISP_NIL; + } + 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; + return AO_LISP_NIL; + } + return cons->car; +} + +ao_poly +ao_lisp_print(struct ao_lisp_cons *cons) +{ + ao_poly val = AO_LISP_NIL; + while (cons) { + val = cons->car; + ao_lisp_poly_print(val); + cons = ao_lisp_poly_cons(cons->cdr); + } + return val; +} + +ao_poly +ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) +{ + ao_poly ret = AO_LISP_NIL; + + while (cons) { + ao_poly car = cons->car; + uint8_t rt = ao_lisp_poly_type(ret); + uint8_t ct = ao_lisp_poly_type(car); + + cons = ao_lisp_poly_cons(cons->cdr); + + if (rt == AO_LISP_NIL) + ret = car; + + else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + int r = ao_lisp_poly_int(ret); + int c = ao_lisp_poly_int(car); + + switch(op) { + case math_plus: + r += c; + break; + case math_minus: + r -= c; + break; + case math_times: + r *= c; + break; + case math_divide: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r /= c; + break; + case math_mod: + if (c == 0) { + ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; + return AO_LISP_NIL; + } + r %= c; + break; + } + ret = ao_lisp_int_poly(r); + } + + 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; + } + } + return ret; +} + +ao_poly +ao_lisp_plus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_plus); +} + +ao_poly +ao_lisp_minus(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_minus); +} + +ao_poly +ao_lisp_times(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_times); +} + +ao_poly +ao_lisp_divide(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_divide); +} + +ao_poly +ao_lisp_mod(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, math_mod); +} + +ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_car] = ao_lisp_car, + [builtin_cdr] = ao_lisp_cdr, + [builtin_cons] = ao_lisp_cons, + [builtin_quote] = ao_lisp_quote, + [builtin_print] = ao_lisp_print, + [builtin_plus] = ao_lisp_plus, + [builtin_minus] = ao_lisp_minus, + [builtin_times] = ao_lisp_times, + [builtin_divide] = ao_lisp_divide, + [builtin_mod] = ao_lisp_mod +}; + diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 60cbb2f3..65908e30 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -20,7 +20,7 @@ static void cons_mark(void *addr) for (;;) { ao_lisp_poly_mark(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); if (!cons) break; if (ao_lisp_mark_memory(cons, sizeof (struct ao_lisp_cons))) @@ -42,42 +42,43 @@ static void cons_move(void *addr) struct ao_lisp_cons *cdr; cons->car = ao_lisp_poly_move(cons->car); - cdr = ao_lisp_move_memory(cons->cdr, sizeof (struct ao_lisp_cons)); + cdr = ao_lisp_poly_cons(cons->cdr); + cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } } -const struct ao_lisp_mem_type ao_lisp_cons_type = { +const struct ao_lisp_type ao_lisp_cons_type = { .mark = cons_mark, .size = cons_size, .move = cons_move, }; struct ao_lisp_cons * -ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr) +ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) { struct ao_lisp_cons *cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); if (!cons) return NULL; cons->car = car; - cons->cdr = cdr; + cons->cdr = ao_lisp_cons_poly(cdr); return cons; } void -ao_lisp_cons_print(struct ao_lisp_cons *cons) +ao_lisp_cons_print(ao_poly c) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; printf("("); while (cons) { if (!first) printf(" "); - fflush(stdout); ao_lisp_poly_print(cons->car); - cons = cons->cdr; + cons = ao_lisp_poly_cons(cons->cdr); first = 0; } printf(")"); diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp new file mode 100644 index 00000000..aa356d45 --- /dev/null +++ b/src/lisp/ao_lisp_const.lisp @@ -0,0 +1 @@ +cadr (lambda (l) (car (cdr l))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 23908e64..b13d4681 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -40,8 +40,8 @@ static uint8_t been_here; #define DBG_POLY(a) #endif -ao_lisp_poly -ao_lisp_eval(ao_lisp_poly v) +ao_poly +ao_lisp_eval(ao_poly v) { struct ao_lisp_cons *formal; int cons = 0; @@ -59,6 +59,7 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = 0; for (;;) { + restart: /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) @@ -68,8 +69,8 @@ ao_lisp_eval(ao_lisp_poly v) if (cons++) { struct ao_lisp_cons *frame; - frame = ao_lisp_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons(ao_lisp_cons_poly(frame), stack); + 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; @@ -83,6 +84,8 @@ ao_lisp_eval(ao_lisp_poly v) /* Evaluate primitive types */ + DBG ("actual: "); DBG_POLY(v); DBG("\n"); + switch (ao_lisp_poly_type(v)) { case AO_LISP_INT: case AO_LISP_STRING: @@ -92,16 +95,42 @@ ao_lisp_eval(ao_lisp_poly v) break; } + if (!cons) + break; + for (;;) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); - formal = ao_lisp_cons(v, NULL); + 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; + + case AO_LISP_MACRO: + v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + if (ao_lisp_poly_type(v) != AO_LISP_CONS) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + + /* Reset frame to the new list */ + actuals = ao_lisp_poly_cons(v); + v = actuals->car; + goto restart; + } + } + } + + formal = ao_lisp_cons_cons(v, NULL); if (formals_tail) - formals_tail->cdr = formal; + formals_tail->cdr = ao_lisp_cons_poly(formal); else formals = formal; formals_tail = formal; - actuals = actuals->cdr; + actuals = ao_lisp_poly_cons(actuals->cdr); DBG("formals: "); DBG_CONS(formals); @@ -113,7 +142,6 @@ ao_lisp_eval(ao_lisp_poly v) /* Process all of the arguments */ if (actuals) { v = actuals->car; - DBG ("actual: "); DBG_POLY(v); DBG("\n"); break; } @@ -123,7 +151,7 @@ ao_lisp_eval(ao_lisp_poly v) if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); - v = b->func(formals->cdr); + v = ao_lisp_func(b) (ao_lisp_poly_cons(formals->cdr)); DBG ("eval: "); DBG_CONS(formals); @@ -131,22 +159,23 @@ ao_lisp_eval(ao_lisp_poly v) DBG_POLY(v); DBG ("\n"); } else { - DBG ("invalid eval\n"); + ao_lisp_exception |= AO_LISP_INVALID; + 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 = frame->cdr; + formals = ao_lisp_poly_cons(frame->cdr); /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != NULL; formal = formal->cdr); + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); formals_tail = formal; - stack = stack->cdr; + 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"); diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 6ee3096d..77f65e95 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,8 @@ #include "ao_lisp.h" void -ao_lisp_int_print(int i) +ao_lisp_int_print(ao_poly p) { + int i = ao_lisp_poly_int(p); printf("%d", i); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c new file mode 100644 index 00000000..21e000bf --- /dev/null +++ b/src/lisp/ao_lisp_make_const.c @@ -0,0 +1,90 @@ +/* + * 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 + +static struct ao_lisp_builtin * +ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { + struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); + + b->type = AO_LISP_BUILTIN; + b->func = func; + b->args = args; + return b; +} + +struct builtin_func { + char *name; + int args; + int func; +}; + +struct builtin_func funcs[] = { + "car", AO_LISP_LEXPR, builtin_car, + "cdr", AO_LISP_LEXPR, builtin_cdr, + "cons", AO_LISP_LEXPR, builtin_cons, + "quote", AO_LISP_NLAMBDA,builtin_quote, + "print", AO_LISP_LEXPR, builtin_print, + "+", AO_LISP_LEXPR, builtin_plus, + "-", AO_LISP_LEXPR, builtin_minus, + "*", AO_LISP_LEXPR, builtin_times, + "/", AO_LISP_LEXPR, builtin_divide, + "%", AO_LISP_LEXPR, builtin_mod +}; + +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly atom, val; + + 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); + a->val = ao_lisp_builtin_poly(b); + } + + for (;;) { + atom = ao_lisp_read(); + if (!atom) + break; + val = ao_lisp_read(); + if (!val) + break; + if (ao_lisp_poly_type(atom) != AO_LISP_ATOM) { + fprintf(stderr, "input must be atom val pairs\n"); + exit(1); + } + ao_lisp_poly_atom(atom)->val = val; + } + + printf("/* constant objects, all referenced from atoms */\n\n"); + 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)); + printf("#ifdef AO_LISP_CONST_BITS\n"); + printf("const uint8_t ao_lisp_const[] = {"); + for (o = 0; o < ao_lisp_top; o++) { + if ((o & 0xf) == 0) + printf("\n\t"); + else + printf(" "); + printf("0x%02x,", ao_lisp_const[o]); + } + printf("\n};\n"); + printf("#endif /* AO_LISP_CONST_BITS */\n"); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d008519b..7295d150 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -12,23 +12,34 @@ * General Public License for more details. */ +#define AO_LISP_CONST_BITS + #include "ao_lisp.h" #include -uint8_t ao_lisp_pool[AO_LISP_POOL]; +uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); + +#ifdef AO_LISP_MAKE_CONST +#include +uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); +#endif + +uint8_t ao_lisp_exception; struct ao_lisp_root { void **addr; - const struct ao_lisp_mem_type *type; + const struct ao_lisp_type *type; }; +#define AO_LISP_ROOT 16 + static struct ao_lisp_root ao_lisp_root[AO_LISP_ROOT]; static uint8_t ao_lisp_busy[AO_LISP_POOL / 32]; static uint8_t ao_lisp_moving[AO_LISP_POOL / 32]; -static uint16_t ao_lisp_top; +uint16_t ao_lisp_top; static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; @@ -59,9 +70,13 @@ static int mark_object(uint8_t *tag, void *addr, int size) { int base; int bound; + if (!addr) return 1; + if ((uint8_t *) addr < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= (uint8_t*) addr) + return 1; + base = (uint8_t *) addr - ao_lisp_pool; bound = base + size; @@ -150,7 +165,7 @@ collect(void) void -ao_lisp_mark(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; @@ -175,7 +190,7 @@ check_move(void *addr, int size) } void * -ao_lisp_move(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_move(const struct ao_lisp_type *type, void *addr) { int size = type->size(addr); @@ -206,19 +221,29 @@ ao_lisp_alloc(int size) { void *addr; - size = (size + 3) & ~3; + size = ao_lisp_mem_round(size); +#ifdef AO_LISP_MAKE_CONST + if (ao_lisp_top + size > AO_LISP_POOL_CONST) { + fprintf(stderr, "Too much constant data, increase AO_LISP_POOL_CONST\n"); + exit(1); + } + addr = ao_lisp_const + ao_lisp_top; +#else if (ao_lisp_top + size > AO_LISP_POOL) { collect(); - if (ao_lisp_top + size > AO_LISP_POOL) + if (ao_lisp_top + size > AO_LISP_POOL) { + ao_lisp_exception |= AO_LISP_OOM; return NULL; + } } addr = ao_lisp_pool + ao_lisp_top; +#endif ao_lisp_top += size; return addr; } int -ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr) +ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; for (i = 0; i < AO_LISP_ROOT; i++) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 1855d945..c6ca0a97 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,91 +14,7 @@ #include "ao_lisp.h" -enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; - -ao_lisp_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) -{ - ao_lisp_poly ret = AO_LISP_NIL; - - while (cons) { - ao_lisp_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - cons = cons->cdr; - - if (rt == AO_LISP_NIL) - ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); - - switch(op) { - case math_plus: - r += c; - break; - case math_minus: - r -= c; - break; - case math_times: - r *= c; - break; - case math_divide: - if (c == 0) - return AO_LISP_NIL; - r /= c; - break; - case math_mod: - if (c == 0) - return AO_LISP_NIL; - r %= c; - break; - } - ret = ao_lisp_int_poly(r); - } - - 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 { - /* XXX exception */ - return AO_LISP_NIL; - } - } - return ret; -} - -ao_lisp_poly -ao_lisp_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_plus); -} - -ao_lisp_poly -ao_lisp_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_minus); -} - -ao_lisp_poly -ao_lisp_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_times); -} - -ao_lisp_poly -ao_lisp_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_divide); -} - -ao_lisp_poly -ao_lisp_mod(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, math_mod); -} +/* static const struct ao_lisp_builtin builtin_plus = { .type = AO_LISP_BUILTIN, @@ -113,7 +29,6 @@ static const struct ao_lisp_atom atom_plus = { .name = "plus" }; -/* static const struct ao_lisp_builtin builtin_minus = { .type = AO_LISP_BUILTIN, .func = ao_lisp_minus @@ -124,9 +39,9 @@ static const struct ao_lisp_builtin builtin_times = { .func = ao_lisp_times }; -*/ const struct ao_lisp_atom const *ao_lisp_builtins[] = { &atom_plus, 0 }; +*/ diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index ccfd2be4..38dcb961 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -14,31 +14,25 @@ #include "ao_lisp.h" -ao_lisp_poly -ao_lisp_poly_print(ao_lisp_poly p) +static void (*const ao_lisp_print_funcs[AO_LISP_NUM_TYPE])(ao_poly) = { + [AO_LISP_CONS] = ao_lisp_cons_print, + [AO_LISP_STRING] = ao_lisp_string_print, + [AO_LISP_INT] = ao_lisp_int_print, + [AO_LISP_ATOM] = ao_lisp_atom_print, + [AO_LISP_BUILTIN] = ao_lisp_builtin_print +}; + +ao_poly +ao_lisp_poly_print(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_cons_print(ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_string_print(ao_lisp_poly_string(p)); - break; - case AO_LISP_INT: - ao_lisp_int_print(ao_lisp_poly_int(p)); - break; - case AO_LISP_ATOM: - ao_lisp_atom_print(ao_lisp_poly_atom(p)); - break; - case AO_LISP_BUILTIN: - ao_lisp_builtin_print(ao_lisp_poly_builtin(p)); - break; - } - return AO_LISP_NIL; + void (*print)(ao_poly) = ao_lisp_print_funcs[ao_lisp_poly_type(p)]; + if (print) + print(p); + return p; } void -ao_lisp_poly_mark(ao_lisp_poly p) +ao_lisp_poly_mark(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: @@ -53,8 +47,8 @@ ao_lisp_poly_mark(ao_lisp_poly p) } } -ao_lisp_poly -ao_lisp_poly_move(ao_lisp_poly p) +ao_poly +ao_lisp_poly_move(ao_poly p) { switch (ao_lisp_poly_type(p)) { case AO_LISP_CONS: diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ccb4ba3a..ea98b976 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -155,8 +155,21 @@ lex_get() if (lex_unget_c) { c = lex_unget_c; lex_unget_c = 0; - } else + } else { +#if AO_LISP_ALTOS + static uint8_t at_eol; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; +#else c = getchar(); +#endif + } return c; } @@ -362,13 +375,13 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_lisp_poly +static ao_poly read_item(void) { struct ao_lisp_atom *atom; char *string; int cons; - ao_lisp_poly v; + ao_poly v; if (!been_here) { ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); @@ -381,7 +394,7 @@ read_item(void) for (;;) { while (parse_token == OPEN) { if (cons++) - read_stack = ao_lisp_cons(ao_lisp_cons_poly(read_cons), read_stack); + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); read_cons = NULL; read_cons_tail = NULL; parse_token = lex(); @@ -416,10 +429,10 @@ read_item(void) v = AO_LISP_NIL; if (--cons) { read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = read_stack->cdr; + 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 = read_cons_tail->cdr) + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; } break; @@ -428,9 +441,9 @@ read_item(void) if (!cons) break; - struct ao_lisp_cons *read = ao_lisp_cons(v, NULL); + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); if (read_cons_tail) - read_cons_tail->cdr = read; + read_cons_tail->cdr = ao_lisp_cons_poly(read); else read_cons = read; read_cons_tail = read; @@ -440,7 +453,7 @@ read_item(void) return v; } -ao_lisp_poly +ao_poly ao_lisp_read(void) { parse_token = lex(); 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; +} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 1ab56933..39c3dc81 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -68,16 +68,18 @@ ao_lisp_string_cat(char *a, char *b) return r; } -const struct ao_lisp_mem_type ao_lisp_string_type = { +const struct ao_lisp_type ao_lisp_string_type = { .mark = string_mark, .size = string_size, .move = string_move, }; void -ao_lisp_string_print(char *s) +ao_lisp_string_print(ao_poly p) { + char *s = ao_lisp_poly_string(p); char c; + putchar('"'); while ((c = *s++)) { switch (c) { diff --git a/src/nucleao-32/.gitignore b/src/nucleao-32/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index a160fd2f..0df44317 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -32,6 +32,17 @@ ALTOS_SRC = \ ao_mutex.c \ ao_usb_stm.c \ ao_serial_stm.c \ + ao_lisp_lex.c \ + ao_lisp_mem.c \ + ao_lisp_cons.c \ + ao_lisp_eval.c \ + ao_lisp_string.c \ + ao_lisp_atom.c \ + ao_lisp_int.c \ + ao_lisp_prim.c \ + ao_lisp_builtin.c \ + ao_lisp_read.c \ + ao_lisp_rep.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_nucleo.c b/src/nucleao-32/ao_nucleo.c index cda889c6..113e2399 100644 --- a/src/nucleao-32/ao_nucleo.c +++ b/src/nucleao-32/ao_nucleo.c @@ -13,6 +13,7 @@ */ #include +#include static uint16_t blink_delay, blink_running; @@ -41,11 +42,17 @@ static void blink_cmd() { ao_sleep(&blink_running); } +static void lisp_cmd() { + ao_lisp_read_eval_print(); +} + static const struct ao_cmds blink_cmds[] = { { blink_cmd, "b \0Blink the green LED" }, + { lisp_cmd, "l\0Run lisp interpreter" }, { 0, 0 } }; + void main(void) { ao_led_init(LEDS_AVAILABLE); diff --git a/src/nucleao-32/flash-loader/.gitignore b/src/nucleao-32/flash-loader/.gitignore new file mode 100644 index 00000000..cb8f78e5 --- /dev/null +++ b/src/nucleao-32/flash-loader/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +nucleo-32* diff --git a/src/test/Makefile b/src/test/Makefile index e841bfde..6c51c421 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -10,7 +10,7 @@ INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quat KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall -DAO_LISP_TEST all: $(PROGS) ao_aprs_data.wav @@ -89,9 +89,11 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.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_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.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_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_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): ao_lisp.h +$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 96f1fd72..810a1528 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -21,9 +21,9 @@ static char *string; int main (int argc, char **argv) { - int i, j; + int i, j; struct ao_lisp_atom *atom; - ao_lisp_poly poly; + ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -31,37 +31,35 @@ main (int argc, char **argv) for (j = 0; j < 10; j++) { list = 0; string = ao_lisp_string_new(0); - for (i = 0; i < 7; i++) { + for (i = 0; i < 2; i++) { string = ao_lisp_string_cat(string, "a"); - list = ao_lisp_cons(ao_lisp_string_poly(string), list); - list = ao_lisp_cons(ao_lisp_int_poly(i), list); + list = ao_lisp_cons_cons(ao_lisp_string_poly(string), list); + list = ao_lisp_cons_cons(ao_lisp_int_poly(i), list); atom = ao_lisp_atom_intern("ant"); atom->val = ao_lisp_cons_poly(list); - list = ao_lisp_cons(ao_lisp_atom_poly(atom), list); + list = ao_lisp_cons_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf("\n"); } - atom = ao_lisp_atom_intern("ant"); - atom->val = ao_lisp_string_poly(ao_lisp_string_cat("hello world", "")); - - list = ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_cons_poly(ao_lisp_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("plus")), - ao_lisp_cons(ao_lisp_int_poly(3), - ao_lisp_cons(ao_lisp_int_poly(4), NULL)))), - ao_lisp_cons(ao_lisp_int_poly(2), NULL))); + for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { + printf("%s = ", atom->name); + ao_lisp_poly_print(atom->val); + printf("\n"); + } +#if 1 + 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), + ao_lisp_cons_cons(ao_lisp_int_poly(4), NULL)))), + ao_lisp_cons_cons(ao_lisp_int_poly(2), NULL))); printf("list: "); ao_lisp_poly_print(ao_lisp_cons_poly(list)); printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - while ((poly = ao_lisp_read())) { - poly = ao_lisp_eval(poly); - ao_lisp_poly_print(poly); - putchar ('\n'); - fflush(stdout); - } - + ao_lisp_read_eval_print(); +#endif } -- cgit v1.2.3 From 417161dbb36323b5a6572859dedad02ca92fc65c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 16:22:43 -0800 Subject: altos/lisp: Clean up OS integration bits, add defun Provide an abstraction for the OS interface so that it can build more cleanly on Linux and AltOS. Add defun macro. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 1 + src/lambdakey-v1.0/ao_lisp_os.h | 56 ++++++++++++ src/lambdakey-v1.0/ao_pins.h | 2 +- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 19 ++-- src/lisp/ao_lisp_builtin.c | 36 +++++++- src/lisp/ao_lisp_const.lisp | 35 +++++++- src/lisp/ao_lisp_lambda.c | 188 ++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 16 +--- src/lisp/ao_lisp_mem.c | 8 +- src/lisp/ao_lisp_os.h | 51 +++++++++++ src/lisp/ao_lisp_poly.c | 85 +++++++++++++----- src/lisp/ao_lisp_prim.c | 86 ------------------ src/lisp/ao_lisp_read.c | 14 +-- src/test/Makefile | 5 +- 15 files changed, 442 insertions(+), 163 deletions(-) create mode 100644 src/lambdakey-v1.0/ao_lisp_os.h create mode 100644 src/lisp/ao_lisp_lambda.c create mode 100644 src/lisp/ao_lisp_os.h delete mode 100644 src/lisp/ao_lisp_prim.c (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 4db0e290..ef03527e 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -47,6 +47,7 @@ ALTOS_SRC = \ ao_lisp_rep.c \ ao_lisp_frame.c \ ao_lisp_error.c \ + ao_lisp_lambda.c \ ao_exti_stm.c PRODUCT=LambdaKey-v1.0 diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h new file mode 100644 index 00000000..df158f6a --- /dev/null +++ b/src/lambdakey-v1.0/ao_lisp_os.h @@ -0,0 +1,56 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include "ao.h" + +static inline int +ao_lisp_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_lisp_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_lisp_os_led(int led) +{ + ao_led_set(led); +} + +static inline void +ao_lisp_os_delay(int delay) +{ + ao_delay(AO_MS_TO_TICKS(delay)); +} + +#endif diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index 5a840f13..b8429c55 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -25,7 +25,7 @@ #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED #define AO_CMD_LEN 128 -#define AO_LISP_POOL 2560 +#define AO_LISP_POOL 3072 #define AO_STACK_SIZE 1024 #define LEDS_AVAILABLE (AO_LED_RED) diff --git a/src/lisp/Makefile b/src/lisp/Makefile index f7edbe41..9c99f05c 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -14,7 +14,6 @@ SRCS=\ ao_lisp_atom.c \ ao_lisp_int.c \ ao_lisp_poly.c \ - ao_lisp_prim.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ @@ -24,7 +23,7 @@ SRCS=\ OBJS=$(SRCS:.c=.o) -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g +CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. HDRS=\ ao_lisp.h \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 82ba5a20..de55b307 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,17 +15,10 @@ #ifndef _AO_LISP_H_ #define _AO_LISP_H_ -#include - -#if !defined(AO_LISP_TEST) && !defined(AO_LISP_MAKE_CONST) -#include -#define AO_LISP_ALTOS 1 -#define abort() ao_panic(1) -#endif - #include #include -#include +//#include +#include #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 @@ -45,6 +38,8 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_last _atom("last") #define _ao_lisp_atom_cond _atom("cond") #define _ao_lisp_atom_lambda _atom("lambda") +#define _ao_lisp_atom_led _atom("led") +#define _ao_lisp_atom_delay _atom("delay") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +94,7 @@ ao_lisp_is_const(ao_poly poly) { static inline void * ao_lisp_ref(ao_poly poly) { if (poly == 0xBEEF) - abort(); + ao_lisp_abort(); if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) @@ -227,12 +222,14 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, + builtin_delay, + builtin_led, _builtin_last }; typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); -extern ao_lisp_func_t ao_lisp_builtins[]; +extern const ao_lisp_func_t ao_lisp_builtins[]; static inline ao_lisp_func_t ao_lisp_func(struct ao_lisp_builtin *b) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index c38ba165..5bd180e2 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -72,11 +72,13 @@ static const ao_poly builtin_names[] = { [builtin_greater] = _ao_lisp_atom_3e, [builtin_less_equal] = _ao_lisp_atom_3c3d, [builtin_greater_equal] = _ao_lisp_atom_3e3d, + [builtin_delay] = _ao_lisp_atom_delay, + [builtin_led] = _ao_lisp_atom_led, }; static char * ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (0 <= b && b < _builtin_last) + if (b < _builtin_last) return ao_lisp_poly_atom(builtin_names[b])->name; return "???"; } @@ -448,7 +450,33 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) return ao_lisp_compare(cons, builtin_greater_equal); } -ao_lisp_func_t ao_lisp_builtins[] = { +ao_poly +ao_lisp_led(struct ao_lisp_cons *cons) +{ + ao_poly led; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + led = ao_lisp_arg(cons, 0); + ao_lisp_os_led(ao_lisp_poly_int(led)); + return led; +} + +ao_poly +ao_lisp_delay(struct ao_lisp_cons *cons) +{ + ao_poly delay; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + delay = ao_lisp_arg(cons, 0); + ao_lisp_os_delay(ao_lisp_poly_int(delay)); + return delay; +} + +const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_lambda] = ao_lisp_lambda, [builtin_lexpr] = ao_lisp_lexpr, [builtin_nlambda] = ao_lisp_nlambda, @@ -472,6 +500,8 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_less] = ao_lisp_less, [builtin_greater] = ao_lisp_greater, [builtin_less_equal] = ao_lisp_less_equal, - [builtin_greater_equal] = ao_lisp_greater_equal + [builtin_greater_equal] = ao_lisp_greater_equal, + [builtin_led] = ao_lisp_led, + [builtin_delay] = ao_lisp_delay, }; diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 621fefc4..08a511d9 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,9 +14,13 @@ (setq 1+ (lambda (x) (+ x 1))) (setq 1- (lambda (x) (- x 1))) - ; define a variable without returning the value + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated + ; -(set 'def (macro (def-param) +(setq def (macro (def-param) (list 'progn (list @@ -127,3 +131,30 @@ ) ) ) + + ; + ; A slightly more convenient form + ; for defining lambdas. + ; + ; (defun () s-exprs) + ; + +(def defun (macro (defun-param) + (let ((name (car defun-param)) + (args (cadr defun-param)) + (exprs (cdr (cdr defun-param)))) + (list + def + name + (list + 'lambda + args + (cond ((cdr exprs) + (cons progn exprs)) + ((car exprs)) + ) + ) + ) + ) + ) + ) diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c new file mode 100644 index 00000000..cc5af4bc --- /dev/null +++ b/src/lisp/ao_lisp_lambda.c @@ -0,0 +1,188 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_lambda); +} + +void +lambda_mark(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_mark(lambda->code, 0); + ao_lisp_poly_mark(lambda->frame, 0); +} + +void +lambda_move(void *addr) +{ + struct ao_lisp_lambda *lambda = addr; + + ao_lisp_poly_move(&lambda->code, 0); + ao_lisp_poly_move(&lambda->frame, 0); +} + +const struct ao_lisp_type ao_lisp_lambda_type = { + .size = lambda_size, + .mark = lambda_mark, + .move = lambda_move, +}; + +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; +} + +void +ao_lisp_lambda_print(ao_poly poly) +{ + struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); + struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); + + printf("("); + printf("%s", ao_lisp_args_name(lambda->args)); + while (cons) { + printf(" "); + ao_lisp_poly_print(cons->car); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf(")"); +} + +ao_poly +ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) +{ + struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + struct ao_lisp_cons *arg; + int f; + + if (!lambda) + return AO_LISP_NIL; + + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, code, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + f = 0; + arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + while (arg) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); + arg = ao_lisp_poly_cons(arg->cdr); + f++; + } + + lambda->type = AO_LISP_LAMBDA; + lambda->args = args; + lambda->code = ao_lisp_cons_poly(code); + lambda->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); + DBG_STACK(); + return ao_lisp_lambda_poly(lambda); +} + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); +} + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); +} + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); +} + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons) +{ + return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); +} + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *code; + struct ao_lisp_cons *args; + struct ao_lisp_frame *next_frame; + int args_wanted; + int args_provided; + + code = ao_lisp_poly_cons(lambda->code); + DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); + args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (lambda->args == AO_LISP_FUNC_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); + switch (lambda->args) { + case AO_LISP_FUNC_LAMBDA: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + 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_FUNC_LEXPR: + case AO_LISP_FUNC_NLAMBDA: + case AO_LISP_FUNC_MACRO: + DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(cons->cdr); DBG("\n"); + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + } + next_frame->next = lambda->frame; + DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); + ao_lisp_frame_current = next_frame; + ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG_STACK(); + return ao_lisp_arg(code, 1); +} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 501052b9..6f852f9d 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -57,20 +57,12 @@ struct builtin_func funcs[] = { ">", AO_LISP_FUNC_LEXPR, builtin_greater, "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, + "delay", AO_LISP_FUNC_LAMBDA, builtin_delay, + "led", AO_LISP_FUNC_LEXPR, builtin_led, }; #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 @@ -102,10 +94,6 @@ main(int argc, char **argv) ao_lisp_builtin_poly(b)); } - /* atoms for syntax */ - for (i = 0; i < N_ATOM; i++) - (void) ao_lisp_atom_intern(atoms[i]); - /* boolean constants */ ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 476843d8..66e09db0 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -331,7 +331,7 @@ ao_lisp_collect(void) move_object(); DBG("\tbusy size %d\n", move_size); if (move_size == 0) - abort(); + ao_lisp_abort(); clear_object(ao_lisp_busy, move_old, move_size); mark_object(ao_lisp_busy, move_new, move_size); if (busy_object(ao_lisp_cons, move_old)) { @@ -431,7 +431,7 @@ ao_lisp_move(const struct ao_lisp_type *type, void **ref) #endif DBG_MOVE("object %d\n", DBG_OFFSET(addr)); if (!AO_LISP_IS_POOL(a)) - abort(); + ao_lisp_abort(); DBG_MOVE_IN(); addr = check_move(addr, size); if (addr != *ref) @@ -495,7 +495,7 @@ ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); if (type >= AO_LISP_NUM_TYPE) - abort(); + ao_lisp_abort(); lisp_type = ao_lisp_types[type]; if (!lisp_type) @@ -601,7 +601,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 1; } } - abort(); + ao_lisp_abort(); return 0; } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h new file mode 100644 index 00000000..55ffed50 --- /dev/null +++ b/src/lisp/ao_lisp_os.h @@ -0,0 +1,51 @@ +/* + * 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; version 2 of the License. + * + * 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. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include +#include +#include + +static inline int +ao_lisp_getc() { + return getchar(); +} + +static inline void +ao_lisp_abort(void) +{ + abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +static inline void +ao_lisp_os_delay(int delay) +{ + struct timespec ts = { + .tv_sec = delay / 1000, + .tv_nsec = (delay % 1000) * 1000000, + }; + nanosleep(&ts, NULL); +} +#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index c6ca0a97..bfd75ae3 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,34 +14,73 @@ #include "ao_lisp.h" -/* +#if 0 +#define DBG(...) printf (__VA_ARGS__) +#else +#define DBG(...) +#endif -static const struct ao_lisp_builtin builtin_plus = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_plus, - .name = "+" +struct ao_lisp_funcs { + void (*print)(ao_poly); + void (*patom)(ao_poly); }; -static const struct ao_lisp_atom atom_plus = { - .type = AO_LISP_ATOM, - .val = AO_LISP_OTHER_POLY(&builtin_plus), - .next = AO_LISP_ATOM_CONST, - .name = "plus" +static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = { + .print = ao_lisp_cons_print, + .patom = ao_lisp_cons_patom, + }, + [AO_LISP_STRING] = { + .print = ao_lisp_string_print, + .patom = ao_lisp_string_patom, + }, + [AO_LISP_INT] = { + .print = ao_lisp_int_print, + .patom = ao_lisp_int_print, + }, + [AO_LISP_ATOM] = { + .print = ao_lisp_atom_print, + .patom = ao_lisp_atom_print, + }, + [AO_LISP_BUILTIN] = { + .print = ao_lisp_builtin_print, + .patom = ao_lisp_builtin_print, + }, + [AO_LISP_FRAME] = { + .print = ao_lisp_frame_print, + .patom = ao_lisp_frame_print, + }, + [AO_LISP_LAMBDA] = { + .print = ao_lisp_lambda_print, + .patom = ao_lisp_lambda_print, + }, }; -static const struct ao_lisp_builtin builtin_minus = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_minus -}; +static const struct ao_lisp_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_lisp_poly_type(p); -static const struct ao_lisp_builtin builtin_times = { - .type = AO_LISP_BUILTIN, - .func = ao_lisp_times -}; + if (type < AO_LISP_NUM_TYPE) + return &ao_lisp_funcs[type]; + return NULL; +} +void +ao_lisp_poly_print(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->print) + f->print(p); +} + +void +ao_lisp_poly_patom(ao_poly p) +{ + const struct ao_lisp_funcs *f = funcs(p); + + if (f && f->patom) + f->patom(p); +} -const struct ao_lisp_atom const *ao_lisp_builtins[] = { - &atom_plus, - 0 -}; -*/ diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c deleted file mode 100644 index bfd75ae3..00000000 --- a/src/lisp/ao_lisp_prim.c +++ /dev/null @@ -1,86 +0,0 @@ -/* - * 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" - -#if 0 -#define DBG(...) printf (__VA_ARGS__) -#else -#define DBG(...) -#endif - -struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .print = ao_lisp_cons_print, - .patom = ao_lisp_cons_patom, - }, - [AO_LISP_STRING] = { - .print = ao_lisp_string_print, - .patom = ao_lisp_string_patom, - }, - [AO_LISP_INT] = { - .print = ao_lisp_int_print, - .patom = ao_lisp_int_print, - }, - [AO_LISP_ATOM] = { - .print = ao_lisp_atom_print, - .patom = ao_lisp_atom_print, - }, - [AO_LISP_BUILTIN] = { - .print = ao_lisp_builtin_print, - .patom = ao_lisp_builtin_print, - }, - [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, - }, - [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, - }, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ - uint8_t type = ao_lisp_poly_type(p); - - if (type < AO_LISP_NUM_TYPE) - return &ao_lisp_funcs[type]; - return NULL; -} - -void -ao_lisp_poly_print(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->print) - f->print(p); -} - -void -ao_lisp_poly_patom(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->patom) - f->patom(p); -} - diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index bc1eb36b..3a2ef7f1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -156,19 +156,7 @@ lex_get() c = lex_unget_c; lex_unget_c = 0; } else { -#if AO_LISP_ALTOS - static uint8_t at_eol; - - if (at_eol) { - ao_cmd_readline(); - at_eol = 0; - } - c = ao_cmd_lex(); - if (c == '\n') - at_eol = 1; -#else - c = getchar(); -#endif + c = ao_lisp_getc(); } return c; } diff --git a/src/test/Makefile b/src/test/Makefile index 7395e832..d6777090 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -88,11 +88,8 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm - -#AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_lex.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_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_atom.o ao_lisp_int.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_lambda.o ao_lisp_error.o -- cgit v1.2.3 From d46ca67f93e9ecbc4d8c051c3fbdead85490b690 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 21:07:09 -0800 Subject: altos/lisp: Make ao_lisp_ref and ao_lisp_poly non-inline These functions are pretty large and end up consuming quite a bit of space if inlined everywhere they are used. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 23 ++++------------------- src/lisp/ao_lisp_poly.c | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+), 19 deletions(-) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 86a5ddcf..7a165cd8 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -99,26 +99,11 @@ ao_lisp_is_const(ao_poly poly) { #define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) #define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -static inline void * -ao_lisp_ref(ao_poly poly) { - if (poly == 0xBEEF) - ao_lisp_abort(); - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); - return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); -} +void * +ao_lisp_ref(ao_poly poly); -static inline ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_LISP_NIL; - if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; - return (a - AO_LISP_POOL_BASE) | type; -} +ao_poly +ao_lisp_poly(const void *addr, ao_poly type); struct ao_lisp_type { int (*size)(void *addr); diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index bfd75ae3..9717fd73 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -84,3 +84,21 @@ ao_lisp_poly_patom(ao_poly p) f->patom(p); } +void * +ao_lisp_ref(ao_poly poly) { + if (poly == AO_LISP_NIL) + return NULL; + if (poly & AO_LISP_CONST) + return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); +} + +ao_poly +ao_lisp_poly(const void *addr, ao_poly type) { + const uint8_t *a = addr; + if (a == NULL) + return AO_LISP_NIL; + if (AO_LISP_IS_CONST(a)) + return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; + return (a - AO_LISP_POOL_BASE) | type; +} -- cgit v1.2.3 From bcf5eb5825b1217d74f117b02d09b4ce4b007beb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 16 Nov 2016 14:12:59 -0800 Subject: altos/lisp: Eliminate compiler warning about array bounds at -O3 Using ao_lisp_pool - 4 caused the compiler to whinge about computing an address outside the bounds of the array. Sigh. Restructure the code to do the adjustment-by-4 in the integer computations instead of the pointer ones. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 3 --- src/lisp/ao_lisp_mem.c | 17 ----------------- src/lisp/ao_lisp_poly.c | 8 ++++---- src/test/Makefile | 2 +- 4 files changed, 5 insertions(+), 25 deletions(-) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index ea8d98b5..25d13fa3 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -118,9 +118,6 @@ ao_lisp_is_const(ao_poly poly) { return poly & AO_LISP_CONST; } -#define AO_LISP_POOL_BASE (ao_lisp_pool - 4) -#define AO_LISP_CONST_BASE (ao_lisp_const - 4) - #define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) #define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 53ebf757..12a5ba55 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -252,23 +252,6 @@ static inline uint16_t pool_offset(void *addr) { return ((uint8_t *) addr) - ao_lisp_pool; } -/* - * Convert back and forth between 'poly's used - * as short addresses in the pool and addresses. - * These are used in the chunk code. - */ -static inline ao_poly pool_poly(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - AO_LISP_POOL_BASE; -} - -static inline void *pool_ref(ao_poly p) { - return AO_LISP_POOL_BASE + p; -} - static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 9717fd73..236176e7 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -89,8 +89,8 @@ ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) return NULL; if (poly & AO_LISP_CONST) - return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); - return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); + return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); } ao_poly @@ -99,6 +99,6 @@ ao_lisp_poly(const void *addr, ao_poly type) { if (a == NULL) return AO_LISP_NIL; if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; - return (a - AO_LISP_POOL_BASE) | type; + return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; + return (a - ao_lisp_pool + 4) | type; } diff --git a/src/test/Makefile b/src/test/Makefile index fae46ac8..0eaa9421 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -10,7 +10,7 @@ INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quat KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O3 -g -Wall -DAO_LISP_TEST -no-pie +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall -DAO_LISP_TEST -no-pie all: $(PROGS) ao_aprs_data.wav -- cgit v1.2.3 From e600fc409c577eec02af612a36431c477a9c875e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 19:04:05 -0800 Subject: altos/lisp: Add continuations This provides call/cc and makes 'stacks' visible to the application. Signed-off-by: Keith Packard --- src/lisp/Makefile | 1 + src/lisp/ao_lisp.h | 77 +++++++++--- src/lisp/ao_lisp_builtin.c | 6 +- src/lisp/ao_lisp_error.c | 82 +++++-------- src/lisp/ao_lisp_eval.c | 151 ++++------------------- src/lisp/ao_lisp_frame.c | 44 ++++--- src/lisp/ao_lisp_lambda.c | 3 +- src/lisp/ao_lisp_make_const.c | 3 +- src/lisp/ao_lisp_mem.c | 28 +++++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_stack.c | 279 ++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 461 insertions(+), 217 deletions(-) create mode 100644 src/lisp/ao_lisp_stack.c (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 15297999..dd5a0cb4 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -21,6 +21,7 @@ SRCS=\ ao_lisp_eval.c \ ao_lisp_rep.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index bcefbabf..a8e1715a 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -75,6 +75,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_eof _atom("eof") #define _ao_lisp_atom_save _atom("save") #define _ao_lisp_atom_restore _atom("restore") +#define _ao_lisp_atom_call2fcc _atom("call/cc") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -99,7 +100,11 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA]; #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 -#define AO_LISP_NUM_TYPE 8 +#define AO_LISP_STACK 8 +#define AO_LISP_NUM_TYPE 9 + +/* Leave two bits for types to use as they please */ +#define AO_LISP_OTHER_TYPE_MASK 0x3f #define AO_LISP_NIL 0 @@ -153,22 +158,17 @@ struct ao_lisp_val { struct ao_lisp_frame { uint8_t type; - uint8_t _num; + uint8_t num; ao_poly prev; struct ao_lisp_val vals[]; }; -#define AO_LISP_FRAME_NUM_MASK 0x7f - -/* Set when the frame escapes the lambda */ +/* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 - -static inline int ao_lisp_frame_num(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_NUM_MASK; -} +#define AO_LISP_FRAME_PRINT 0x40 static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->_num & AO_LISP_FRAME_MARK; + return f->type & AO_LISP_FRAME_MARK; } static inline struct ao_lisp_frame * @@ -195,6 +195,7 @@ enum eval_state { }; struct ao_lisp_stack { + uint8_t type; /* AO_LISP_STACK */ uint8_t state; /* enum eval_state */ ao_poly prev; /* previous stack frame */ ao_poly sexprs; /* expressions to evaluate */ @@ -204,6 +205,17 @@ struct ao_lisp_stack { ao_poly list; /* most recent function call */ }; +#define AO_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ +#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { + return s->type & AO_LISP_STACK_MARK; +} + +static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { + s->type |= AO_LISP_STACK_MARK; +} + static inline struct ao_lisp_stack * ao_lisp_poly_stack(ao_poly p) { @@ -216,8 +228,6 @@ ao_lisp_stack_poly(struct ao_lisp_stack *stack) return ao_lisp_poly(stack, AO_LISP_OTHER); } -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 @@ -276,6 +286,7 @@ enum ao_lisp_builtin_id { builtin_led, builtin_save, builtin_restore, + builtin_call_cc, _builtin_last }; @@ -315,7 +326,7 @@ ao_lisp_poly_other(ao_poly poly) { static inline uint8_t ao_lisp_other_type(void *other) { - return *((uint8_t *) other); + return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; } static inline ao_poly @@ -455,6 +466,12 @@ ao_lisp_string_stash(int id, char *string); char * ao_lisp_string_fetch(int id); +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack); + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id); + void ao_lisp_poly_stash(int id, ao_poly poly); @@ -617,6 +634,8 @@ ao_lisp_frame_print(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; +extern const char *ao_lisp_state_names[]; + struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); @@ -646,12 +665,40 @@ ao_lisp_save(struct ao_lisp_cons *cons); ao_poly ao_lisp_restore(struct ao_lisp_cons *cons); -/* error */ +/* stack */ extern const struct ao_lisp_type ao_lisp_stack_type; +extern struct ao_lisp_stack *ao_lisp_stack; +extern struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack); + +int +ao_lisp_stack_push(void); + +void +ao_lisp_stack_pop(void); + +void +ao_lisp_stack_clear(void); + +void +ao_lisp_stack_print(ao_poly stack); + +ao_poly +ao_lisp_stack_eval(void); + +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons); + +/* error */ + +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); void -ao_lisp_stack_print(void); +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6cbcb92c..4c845307 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -86,6 +86,7 @@ static const ao_poly builtin_names[] = { [builtin_led] = _ao_lisp_atom_led, [builtin_save] = _ao_lisp_atom_save, [builtin_restore] = _ao_lisp_atom_restore, + [builtin_call_cc] = _ao_lisp_atom_call2fcc, }; @@ -117,9 +118,7 @@ void ao_lisp_builtin_print(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("[builtin %s %s]", - ao_lisp_args_name(builtin->args), - ao_lisp_builtin_name(builtin->func)); + printf("%s", ao_lisp_builtin_name(builtin->func)); } ao_poly @@ -599,5 +598,6 @@ const ao_lisp_func_t ao_lisp_builtins[] = { [builtin_delay] = ao_lisp_delay, [builtin_save] = ao_lisp_save, [builtin_restore] = ao_lisp_restore, + [builtin_call_cc] = ao_lisp_call_cc, }; diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 937739e9..54a9be10 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,23 +15,24 @@ #include "ao_lisp.h" #include -static void -ao_lisp_error_poly(char *name, ao_poly poly) +void +ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - - if (cons) { - while (cons) { + if (poly) { + while (poly) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); if (!first) printf("\t\t "); else first = 0; ao_lisp_poly_print(cons->car); printf("\n"); - cons = ao_lisp_poly_cons(cons->cdr); + if (poly == last) + break; + poly = cons->cdr; } printf("\t\t )\n"); } else @@ -48,7 +49,7 @@ static void tabs(int indent) printf("\t"); } -static void +void ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) { int f; @@ -56,51 +57,30 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) { - tabs(indent); - printf(" "); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + printf("\n"); } - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); - printf("\n"); + if (frame->prev) + ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - } - tabs(indent); - printf(" }\n"); + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); } -static const char *state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", -}; - -void -ao_lisp_stack_print(void) -{ - struct ao_lisp_stack *s; - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); - printf("Stack:\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); - printf("\t\tstate: %s\n", state_names[s->state]); -// printf("\t\tmacro: %s\n", s->macro ? "true" : "false"); - ao_lisp_error_poly ("sexprs: ", s->sexprs); - ao_lisp_error_poly ("values: ", s->values); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); -// ao_lisp_error_frame(2, "mframe: ", ao_lisp_poly_frame(s->macro_frame)); - printf("\t]\n"); - } -} ao_poly ao_lisp_error(int error, char *format, ...) @@ -112,7 +92,9 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - ao_lisp_stack_print(); + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Stack:\n"); + ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ef521605..2460a32a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -16,68 +16,9 @@ #include "ao_lisp.h" #include -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; -struct ao_lisp_stack *ao_lisp_stack_free_list; - ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { @@ -86,72 +27,6 @@ ao_lisp_set_cond(struct ao_lisp_cons *c) return AO_LISP_NIL; } -static void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - - -static int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - } - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - ao_lisp_stack = stack; - ao_lisp_stack_reset(stack); - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -static void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -static void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - static int func_type(ao_poly func) { @@ -162,6 +37,8 @@ func_type(ao_poly func) return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; case AO_LISP_LAMBDA: return ao_lisp_poly_lambda(func)->args; + case AO_LISP_STACK: + return AO_LISP_FUNC_LAMBDA; default: ao_lisp_error(AO_LISP_INVALID, "not a func"); return -1; @@ -392,10 +269,12 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; @@ -404,12 +283,18 @@ ao_lisp_eval_exec(void) ao_lisp_stack->state = eval_progn; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; + case AO_LISP_STACK: + DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); + ao_lisp_v = ao_lisp_stack_eval(); + DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + break; } - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; return 1; } @@ -599,6 +484,16 @@ static int (*const evals[])(void) = { [eval_macro] = ao_lisp_eval_macro, }; +const char *ao_lisp_state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", + "progn", +}; + /* * Called at restore time to reset all execution state */ diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 9d17f6fa..17fa141a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -24,7 +24,7 @@ static int frame_size(void *addr) { struct ao_lisp_frame *frame = addr; - return frame_num_size(ao_lisp_frame_num(frame)); + return frame_num_size(frame->num); } static void @@ -37,7 +37,7 @@ frame_mark(void *addr) MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_mark(v->val, 0); @@ -68,7 +68,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < ao_lisp_frame_num(frame); f++) { + for (f = 0; f < frame->num; f++) { struct ao_lisp_val *v = &frame->vals[f]; ao_lisp_poly_move(&v->atom, 0); @@ -109,15 +109,21 @@ ao_lisp_frame_print(ao_poly p) printf ("{"); if (frame) { - for (f = 0; f < ao_lisp_frame_num(frame); f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); - printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + if (frame->type & AO_LISP_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_LISP_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_lisp_poly_print(frame->vals[f].atom); + printf(" = "); + ao_lisp_poly_print(frame->vals[f].val); + } + if (frame->prev) + ao_lisp_poly_print(frame->prev); + frame->type &= ~AO_LISP_FRAME_PRINT; } - if (frame->prev) - ao_lisp_poly_print(frame->prev); } printf("}"); } @@ -126,7 +132,7 @@ ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; - for (f = 0; f < ao_lisp_frame_num(frame); f++) + for (f = 0; f < frame->num; f++) if (frame->vals[f].atom == atom) return &frame->vals[f].val; return NULL; @@ -175,7 +181,7 @@ ao_lisp_frame_new(int num) return NULL; } frame->type = AO_LISP_FRAME; - frame->_num = num; + frame->num = num; frame->prev = AO_LISP_NIL; memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); return frame; @@ -186,7 +192,7 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) { if (!frame) return AO_LISP_NIL; - frame->_num |= AO_LISP_FRAME_MARK; + frame->type |= AO_LISP_FRAME_MARK; return ao_lisp_frame_poly(frame); } @@ -194,7 +200,7 @@ void ao_lisp_frame_free(struct ao_lisp_frame *frame) { if (!ao_lisp_frame_marked(frame)) { - int num = ao_lisp_frame_num(frame); + int num = frame->num; if (num < AO_LISP_FRAME_FREE) { frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; @@ -209,7 +215,7 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) struct ao_lisp_frame *new; int copy; - if (new_num == ao_lisp_frame_num(frame)) + if (new_num == frame->num) return frame; new = ao_lisp_frame_new(new_num); if (!new) @@ -220,8 +226,8 @@ ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) */ frame = *frame_ref; copy = new_num; - if (copy > ao_lisp_frame_num(frame)) - copy = ao_lisp_frame_num(frame); + if (copy > frame->num) + copy = frame->num; memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); new->prev = frame->prev; ao_lisp_frame_free(frame); @@ -239,7 +245,7 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); if (frame) { - f = ao_lisp_frame_num(frame); + f = frame->num; frame = ao_lisp_frame_realloc(frame_ref, f + 1); } else { f = 0; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index e2053a6f..656936cb 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -175,7 +175,8 @@ ao_lisp_lambda_eval(void) args = ao_lisp_poly_cons(args->cdr); vals = ao_lisp_poly_cons(vals->cdr); } - ao_lisp_cons_free(cons); + if (!ao_lisp_stack_marked(ao_lisp_stack)) + ao_lisp_cons_free(cons); cons = NULL; break; case AO_LISP_FUNC_LEXPR: diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 495e48cd..de9c5725 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -71,6 +71,7 @@ struct builtin_func funcs[] = { { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, + { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, }; #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -358,7 +359,7 @@ main(int argc, char **argv) /* Reduce to referenced values */ ao_lisp_collect(AO_LISP_COLLECT_FULL); - for (f = 0; f < ao_lisp_frame_num(ao_lisp_frame_global); f++) { + for (f = 0; f < ao_lisp_frame_global->num; f++) { val = ao_has_macro(ao_lisp_frame_global->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 12a5ba55..0dfad1d7 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -144,6 +144,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_stack *save_stack[3]; static ao_poly save_poly[2]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -155,6 +156,18 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &save_cons[1], }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[0] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[1] + }, + { + .type = &ao_lisp_stack_type, + .addr = (void **) &save_stack[2] + }, { .type = &ao_lisp_string_type, .addr = (void **) &save_string[0] @@ -434,6 +447,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, + [AO_LISP_STACK] = &ao_lisp_stack_type, }; static int @@ -818,6 +832,20 @@ ao_lisp_cons_fetch(int id) return cons; } +void +ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) +{ + save_stack[id] = stack; +} + +struct ao_lisp_stack * +ao_lisp_stack_fetch(int id) +{ + struct ao_lisp_stack *stack = save_stack[id]; + save_stack[id] = NULL; + return stack; +} + void ao_lisp_string_stash(int id, char *string) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 236176e7..800ee06d 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -54,6 +54,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_lambda_print, .patom = ao_lisp_lambda_print, }, + [AO_LISP_STACK] = { + .print = ao_lisp_stack_print, + .patom = ao_lisp_stack_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c new file mode 100644 index 00000000..9c773e83 --- /dev/null +++ b/src/lisp/ao_lisp_stack.c @@ -0,0 +1,279 @@ +/* + * 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. + */ + +#define DBG_EVAL 0 +#include "ao_lisp.h" + +const struct ao_lisp_type ao_lisp_stack_type; + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->sexprs, 0); + ao_lisp_poly_mark(stack->values, 0); + /* no need to mark values_tail */ + ao_lisp_poly_mark(stack->frame, 0); + ao_lisp_poly_mark(stack->list, 0); + stack = ao_lisp_poly_stack(stack->prev); + if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + while (stack) { + struct ao_lisp_stack *prev; + int ret; + (void) ao_lisp_poly_move(&stack->sexprs, 0); + (void) ao_lisp_poly_move(&stack->values, 0); + (void) ao_lisp_poly_move(&stack->values_tail, 0); + (void) ao_lisp_poly_move(&stack->frame, 0); + (void) ao_lisp_poly_move(&stack->list, 0); + prev = ao_lisp_poly_stack(stack->prev); + if (!prev) + break; + ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); + if (prev != ao_lisp_poly_stack(stack->prev)) + stack->prev = ao_lisp_stack_poly(prev); + if (ret) + break; + stack = prev; + } +} + +const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move, + .name = "stack" +}; + +struct ao_lisp_stack *ao_lisp_stack_free_list; + +void +ao_lisp_stack_reset(struct ao_lisp_stack *stack) +{ + stack->state = eval_sexpr; + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; +} + +static struct ao_lisp_stack * +ao_lisp_stack_new(void) +{ + struct ao_lisp_stack *stack; + + if (ao_lisp_stack_free_list) { + stack = ao_lisp_stack_free_list; + ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); + } else { + stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!stack) + return 0; + stack->type = AO_LISP_STACK; + } + ao_lisp_stack_reset(stack); + return stack; +} + +int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *stack = ao_lisp_stack_new(); + + if (!stack) + return 0; + + stack->prev = ao_lisp_stack_poly(ao_lisp_stack); + stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + stack->list = AO_LISP_NIL; + + ao_lisp_stack = stack; + + DBGI("stack push\n"); + DBG_FRAMES(); + DBG_IN(); + return 1; +} + +void +ao_lisp_stack_pop(void) +{ + ao_poly prev; + struct ao_lisp_frame *prev_frame; + + if (!ao_lisp_stack) + return; + prev = ao_lisp_stack->prev; + if (!ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); + ao_lisp_stack_free_list = ao_lisp_stack; + } + + ao_lisp_stack = ao_lisp_poly_stack(prev); + prev_frame = ao_lisp_frame_current; + if (ao_lisp_stack) + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + else + ao_lisp_frame_current = NULL; + if (ao_lisp_frame_current != prev_frame) + ao_lisp_frame_free(prev_frame); + DBG_OUT(); + DBGI("stack pop\n"); + DBG_FRAMES(); +} + +void +ao_lisp_stack_clear(void) +{ + ao_lisp_stack = NULL; + ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; +} + +void +ao_lisp_stack_print(ao_poly poly) +{ + struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); + + if (s->type & AO_LISP_STACK_PRINT) { + printf("[recurse...]"); + return; + } + while (s) { + s->type |= AO_LISP_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); + ao_lisp_error_poly ("values: ", s->values, s->values_tail); + ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); + ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_LISP_STACK_PRINT; + s = ao_lisp_poly_stack(s->prev); + } +} + +/* + * Copy a stack, being careful to keep everybody referenced + */ +static struct ao_lisp_stack * +ao_lisp_stack_copy(struct ao_lisp_stack *old) +{ + struct ao_lisp_stack *new = NULL; + struct ao_lisp_stack *n, *prev = NULL; + + while (old) { + ao_lisp_stack_stash(0, old); + ao_lisp_stack_stash(1, new); + ao_lisp_stack_stash(2, prev); + n = ao_lisp_stack_new(); + prev = ao_lisp_stack_fetch(2); + new = ao_lisp_stack_fetch(1); + old = ao_lisp_stack_fetch(0); + if (!n) + return NULL; + + ao_lisp_stack_mark(old); + ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); + *n = *old; + + if (prev) + prev->prev = ao_lisp_stack_poly(n); + else + new = n; + prev = n; + + old = ao_lisp_poly_stack(old->prev); + } + return new; +} + +/* + * Evaluate a continuation invocation + */ +ao_poly +ao_lisp_stack_eval(void) +{ + struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); + if (!new) + return AO_LISP_NIL; + + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + + if (!cons || !cons->cdr) + return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); + + new->state = eval_val; + + ao_lisp_stack = new; + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + + return ao_lisp_poly_cons(cons->cdr)->car; +} + +/* + * Call with current continuation. This calls a lambda, passing + * it a single argument which is the current continuation + */ +ao_poly +ao_lisp_call_cc(struct ao_lisp_cons *cons) +{ + struct ao_lisp_stack *new; + ao_poly v; + + /* Make sure the single parameter is a lambda */ + if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) + return AO_LISP_NIL; + + /* go get the lambda */ + ao_lisp_v = ao_lisp_arg(cons, 0); + + /* Note that the whole call chain now has + * a reference to it which may escape + */ + new = ao_lisp_stack_copy(ao_lisp_stack); + if (!new) + return AO_LISP_NIL; + + /* re-fetch cons after the allocation */ + cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); + + /* Reset the arg list to the current stack, + * and call the lambda + */ + + cons->car = ao_lisp_stack_poly(new); + cons->cdr = AO_LISP_NIL; + v = ao_lisp_lambda_eval(); + ao_lisp_stack->sexprs = v; + ao_lisp_stack->state = eval_progn; + return AO_LISP_NIL; +} -- cgit v1.2.3 From 129e07ccc9b8a33491a905a91ca6c5b0509aba9c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 22:53:36 -0800 Subject: altos/lisp: Cleanup some DBG defines Get rid of the remaining duplicate defines. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 3 +-- src/lisp/ao_lisp_poly.c | 6 ------ src/lisp/ao_lisp_read.c | 1 - src/lisp/ao_lisp_stack.c | 1 - 4 files changed, 1 insertion(+), 10 deletions(-) (limited to 'src/lisp/ao_lisp_poly.c') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 1a8e7e91..fa3632b1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -20,7 +20,6 @@ #include #include -//#include #include typedef uint16_t ao_poly; @@ -735,7 +734,7 @@ int ao_lisp_stack_depth; #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) -#define DBG_STACK() ao_lisp_stack_print() +#define DBG_STACK() ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) static inline void ao_lisp_frames_dump(void) { diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 800ee06d..fb3b06fe 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -14,12 +14,6 @@ #include "ao_lisp.h" -#if 0 -#define DBG(...) printf (__VA_ARGS__) -#else -#define DBG(...) -#endif - struct ao_lisp_funcs { void (*print)(ao_poly); void (*patom)(ao_poly); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index b792c2f1..84ef2a61 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" #include "ao_lisp_read.h" diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 9c773e83..ef07b88a 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -12,7 +12,6 @@ * General Public License for more details. */ -#define DBG_EVAL 0 #include "ao_lisp.h" const struct ao_lisp_type ao_lisp_stack_type; -- cgit v1.2.3