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/test/Makefile | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'src/test/Makefile') diff --git a/src/test/Makefile b/src/test/Makefile index 02e1d22b..a409ae13 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,16 +1,16 @@ -vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp PROGS=ao_flight_test ao_flight_test_baro ao_flight_test_accel ao_flight_test_noisy_accel ao_flight_test_mm \ ao_flight_test_metrum \ ao_gps_test ao_gps_test_skytraq ao_gps_test_ublox ao_convert_test ao_convert_pa_test ao_fec_test \ ao_aprs_test ao_micropeak_test ao_fat_test ao_aes_test ao_int64_test \ - ao_ms5607_convert_test ao_quaternion_test + ao_ms5607_convert_test ao_quaternion_test ao_lisp_test INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quaternion.h KALMAN=make-kalman -CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -O0 -g -Wall +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O0 -g -Wall all: $(PROGS) ao_aprs_data.wav @@ -88,3 +88,10 @@ 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_test: $(AO_LISP_OBJS) + cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) + +$(AO_LISP_OBJS): ao_lisp.h -- cgit v1.2.3 From e2f4d25cd6f6f3787d4ee99264732d5b2ce23d4c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 31 Oct 2016 18:53:09 -0700 Subject: altos: Add lisp reader --- src/lisp/ao_lisp.h | 242 +++++++++++++++++++++++++ src/lisp/ao_lisp_eval.c | 52 +++--- src/lisp/ao_lisp_lex.c | 130 -------------- src/lisp/ao_lisp_mem.c | 1 - src/lisp/ao_lisp_read.c | 448 ++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.h | 49 +++++ src/lisp/ao_lisp_string.c | 12 ++ src/test/Makefile | 2 +- src/test/ao_lisp_test.c | 9 + 9 files changed, 792 insertions(+), 153 deletions(-) create mode 100644 src/lisp/ao_lisp.h create mode 100644 src/lisp/ao_lisp_read.c create mode 100644 src/lisp/ao_lisp_read.h (limited to 'src/test/Makefile') diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h new file mode 100644 index 00000000..6667dcc2 --- /dev/null +++ b/src/lisp/ao_lisp.h @@ -0,0 +1,242 @@ +/* + * 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. + */ + +#ifndef _AO_LISP_H_ +#define _AO_LISP_H_ + +#include +#include +#include + + +# define AO_LISP_CONS 0 +# define AO_LISP_INT 1 +# define AO_LISP_STRING 2 +# define AO_LISP_OTHER 3 + +# define AO_LISP_ATOM 4 +# define AO_LISP_BUILTIN 5 + +# 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); +} + +static inline void *ao_lisp_clear_ref(void *addr) { + return (void *) ((intptr_t)addr & ~1); +} + +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; + +struct ao_lisp_mem_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; +}; + +struct ao_lisp_atom { + uint8_t type; + ao_lisp_poly val; + struct ao_lisp_atom *next; + char name[]; +}; + +#define AO_LISP_ATOM_CONST ((struct ao_lisp_atom *) (intptr_t) 1) + +extern const struct ao_lisp_atom *ao_lisp_builtins[]; + +struct ao_lisp_builtin { + uint8_t type; + ao_lisp_poly (*func)(struct ao_lisp_cons *cons); + char name[]; +}; + +static inline void * +ao_lisp_poly_other(ao_lisp_poly poly) { + return (void *) (poly - AO_LISP_OTHER); +} + +static const inline ao_lisp_poly +ao_lisp_other_poly(const void *other) +{ + return (ao_lisp_poly) other + AO_LISP_OTHER; +} + +#define AO_LISP_OTHER_POLY(other) ((ao_lisp_poly)(other) + AO_LISP_OTHER) + +static inline int ao_lisp_poly_type(ao_lisp_poly poly) { + int type = poly & 3; + if (type == AO_LISP_OTHER) + return *((uint8_t *) ao_lisp_poly_other(poly)); + return type; +} + +static inline struct ao_lisp_cons * +ao_lisp_poly_cons(ao_lisp_poly poly) +{ + return (struct ao_lisp_cons *) (poly - AO_LISP_CONS); +} + +static inline ao_lisp_poly +ao_lisp_cons_poly(struct ao_lisp_cons *cons) +{ + return (ao_lisp_poly) cons + AO_LISP_CONS; +} + +static inline int +ao_lisp_poly_int(ao_lisp_poly poly) +{ + return (int) (poly >> 2); +} + +static inline ao_lisp_poly +ao_lisp_int_poly(int i) +{ + return ((ao_lisp_poly) i << 2) + AO_LISP_INT; +} + +static inline char * +ao_lisp_poly_string(ao_lisp_poly poly) +{ + return (char *) (poly - AO_LISP_STRING); +} + +static inline ao_lisp_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) +{ + return (struct ao_lisp_atom *) (poly - AO_LISP_OTHER); +} + +static inline ao_lisp_poly +ao_lisp_atom_poly(struct ao_lisp_atom *a) +{ + return (ao_lisp_poly) a + AO_LISP_OTHER; +} + +static inline struct ao_lisp_builtin * +ao_lisp_poly_builtin(ao_lisp_poly poly) +{ + return (struct ao_lisp_builtin *) (poly - AO_LISP_OTHER); +} + +static inline ao_lisp_poly +ao_lisp_builtin_poly(struct ao_lisp_builtin *b) +{ + return (ao_lisp_poly) b + AO_LISP_OTHER; +} + +/* memory functions */ + +void +ao_lisp_mark(const struct ao_lisp_mem_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); + +/* returns NULL if the object was already moved */ +void * +ao_lisp_move_memory(void *addr, int size); + +void * +ao_lisp_alloc(int size); + +int +ao_lisp_root_add(const struct ao_lisp_mem_type *type, void *addr); + +void +ao_lisp_root_clear(void *addr); + +/* cons */ +extern const struct ao_lisp_mem_type ao_lisp_cons_type; + +struct ao_lisp_cons * +ao_lisp_cons(ao_lisp_poly car, struct ao_lisp_cons *cdr); + +void +ao_lisp_cons_print(struct ao_lisp_cons *cons); + +/* string */ +extern const struct ao_lisp_mem_type ao_lisp_string_type; + +char * +ao_lisp_string_new(int len); + +char * +ao_lisp_string_copy(char *a); + +char * +ao_lisp_string_cat(char *a, char *b); + +void +ao_lisp_string_print(char *s); + +/* atom */ +extern const struct ao_lisp_mem_type ao_lisp_atom_type; + +void +ao_lisp_atom_init(void); + +void +ao_lisp_atom_print(struct ao_lisp_atom *atom); + +struct ao_lisp_atom * +ao_lisp_atom_intern(char *name); + +/* int */ +void +ao_lisp_int_print(int i); + +/* prim */ +ao_lisp_poly +ao_lisp_poly_print(ao_lisp_poly p); + +void +ao_lisp_poly_mark(ao_lisp_poly p); + +ao_lisp_poly +ao_lisp_poly_move(ao_lisp_poly p); + +/* eval */ +ao_lisp_poly +ao_lisp_eval(ao_lisp_poly p); + +/* builtin */ +void +ao_lisp_builtin_print(struct ao_lisp_builtin *b); + +/* read */ +ao_lisp_poly +ao_lisp_read(void); + +#endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 531e3b72..23908e64 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -30,6 +30,16 @@ static struct ao_lisp_cons *formals; static struct ao_lisp_cons *formals_tail; static uint8_t been_here; +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#define DBG_CONS(a) ao_lisp_cons_print(a) +#define DBG_POLY(a) ao_lisp_poly_print(a) +#else +#define DBG(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#endif + ao_lisp_poly ao_lisp_eval(ao_lisp_poly v) { @@ -66,9 +76,9 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = NULL; v = actuals->car; - printf("start: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("start: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("start: formals"); ao_lisp_cons_print(formals); printf("\n"); + DBG("start: stack"); DBG_CONS(stack); DBG("\n"); + DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); + DBG("start: formals"); DBG_CONS(formals); DBG("\n"); } /* Evaluate primitive types */ @@ -83,7 +93,7 @@ ao_lisp_eval(ao_lisp_poly v) } for (;;) { - printf("add formal: "); ao_lisp_poly_print(v); printf("\n"); + DBG("add formal: "); DBG_POLY(v); DBG("\n"); formal = ao_lisp_cons(v, NULL); if (formals_tail) @@ -93,17 +103,17 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = formal; actuals = actuals->cdr; - printf("formals: "); - ao_lisp_cons_print(formals); - printf("\n"); - printf("actuals: "); - ao_lisp_cons_print(actuals); - printf("\n"); + DBG("formals: "); + DBG_CONS(formals); + DBG("\n"); + DBG("actuals: "); + DBG_CONS(actuals); + DBG("\n"); /* Process all of the arguments */ if (actuals) { v = actuals->car; - printf ("actual: "); ao_lisp_poly_print(v); printf("\n"); + DBG ("actual: "); DBG_POLY(v); DBG("\n"); break; } @@ -115,13 +125,13 @@ ao_lisp_eval(ao_lisp_poly v) v = b->func(formals->cdr); - printf ("eval: "); - ao_lisp_cons_print(formals); - printf(" -> "); - ao_lisp_poly_print(v); - printf ("\n"); + DBG ("eval: "); + DBG_CONS(formals); + DBG(" -> "); + DBG_POLY(v); + DBG ("\n"); } else { - printf ("invalid eval\n"); + DBG ("invalid eval\n"); } if (--cons) { @@ -137,11 +147,11 @@ ao_lisp_eval(ao_lisp_poly v) formals_tail = formal; stack = stack->cdr; - printf("stack pop: stack"); ao_lisp_cons_print(stack); printf("\n"); - printf("stack pop: actuals"); ao_lisp_cons_print(actuals); printf("\n"); - printf("stack pop: formals"); ao_lisp_cons_print(formals); printf("\n"); + DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); + DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); + DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { - printf("done func\n"); + DBG("done func\n"); break; } } diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c index d62db872..fe7c47f4 100644 --- a/src/lisp/ao_lisp_lex.c +++ b/src/lisp/ao_lisp_lex.c @@ -14,133 +14,3 @@ #include "ao_lisp.h" -const uint32_t classTable[256] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE|COMMENT, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|QUOTEC, /* ' */ - PRINTABLE|BRA, /* ( */ - PRINTABLE|KET, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|DOT, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE|EXP, /* E */ - PRINTABLE, /* F */ - PRINTABLE, /* G */ - PRINTABLE, /* H */ - PRINTABLE, /* I */ - PRINTABLE, /* J */ - PRINTABLE, /* K */ - PRINTABLE, /* L */ - PRINTABLE, /* M */ - PRINTABLE, /* N */ - PRINTABLE, /* O */ - PRINTABLE, /* P */ - PRINTABLE, /* Q */ - PRINTABLE, /* R */ - PRINTABLE, /* S */ - PRINTABLE, /* T */ - PRINTABLE, /* U */ - PRINTABLE, /* V */ - PRINTABLE, /* W */ - PRINTABLE, /* X */ - PRINTABLE, /* Y */ - PRINTABLE, /* Z */ - PRINTABLE|BRA, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ - PRINTABLE|KET, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE|EXP, /* e */ - PRINTABLE, /* f */ - PRINTABLE, /* g */ - PRINTABLE, /* h */ - PRINTABLE, /* i */ - PRINTABLE, /* j */ - PRINTABLE, /* k */ - PRINTABLE, /* l */ - PRINTABLE, /* m */ - PRINTABLE, /* n */ - PRINTABLE, /* o */ - PRINTABLE, /* p */ - PRINTABLE, /* q */ - PRINTABLE, /* r */ - PRINTABLE, /* s */ - PRINTABLE, /* t */ - PRINTABLE, /* u */ - PRINTABLE, /* v */ - PRINTABLE, /* w */ - PRINTABLE, /* x */ - PRINTABLE, /* y */ - PRINTABLE, /* z */ - PRINTABLE|BRA, /* { */ - PRINTABLE|VBAR, /* | */ - PRINTABLE|KET, /* } */ - PRINTABLE|TWIDDLE, /* ~ */ - IGNORE, /* ^? */ -}; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f6a108e9..d008519b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -120,7 +120,6 @@ collect(void) { int i; - printf("collect\n"); /* Mark */ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); for (i = 0; i < AO_LISP_ROOT; i++) diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c new file mode 100644 index 00000000..ccb4ba3a --- /dev/null +++ b/src/lisp/ao_lisp_read.c @@ -0,0 +1,448 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include "ao_lisp_read.h" + +static const uint16_t lex_classes[128] = { + IGNORE, /* ^@ */ + IGNORE, /* ^A */ + IGNORE, /* ^B */ + IGNORE, /* ^C */ + IGNORE, /* ^D */ + IGNORE, /* ^E */ + IGNORE, /* ^F */ + IGNORE, /* ^G */ + IGNORE, /* ^H */ + WHITE, /* ^I */ + WHITE, /* ^J */ + WHITE, /* ^K */ + WHITE, /* ^L */ + WHITE, /* ^M */ + IGNORE, /* ^N */ + IGNORE, /* ^O */ + IGNORE, /* ^P */ + IGNORE, /* ^Q */ + IGNORE, /* ^R */ + IGNORE, /* ^S */ + IGNORE, /* ^T */ + IGNORE, /* ^U */ + IGNORE, /* ^V */ + IGNORE, /* ^W */ + IGNORE, /* ^X */ + IGNORE, /* ^Y */ + IGNORE, /* ^Z */ + IGNORE, /* ^[ */ + IGNORE, /* ^\ */ + IGNORE, /* ^] */ + IGNORE, /* ^^ */ + IGNORE, /* ^_ */ + PRINTABLE|WHITE, /* */ + PRINTABLE, /* ! */ + PRINTABLE|STRINGC, /* " */ + PRINTABLE|COMMENT, /* # */ + PRINTABLE, /* $ */ + PRINTABLE, /* % */ + PRINTABLE, /* & */ + PRINTABLE|QUOTEC, /* ' */ + PRINTABLE|BRA, /* ( */ + PRINTABLE|KET, /* ) */ + PRINTABLE, /* * */ + PRINTABLE|SIGN, /* + */ + PRINTABLE, /* , */ + PRINTABLE|SIGN, /* - */ + PRINTABLE, /* . */ + PRINTABLE, /* / */ + PRINTABLE|DIGIT, /* 0 */ + PRINTABLE|DIGIT, /* 1 */ + PRINTABLE|DIGIT, /* 2 */ + PRINTABLE|DIGIT, /* 3 */ + PRINTABLE|DIGIT, /* 4 */ + PRINTABLE|DIGIT, /* 5 */ + PRINTABLE|DIGIT, /* 6 */ + PRINTABLE|DIGIT, /* 7 */ + PRINTABLE|DIGIT, /* 8 */ + PRINTABLE|DIGIT, /* 9 */ + PRINTABLE, /* : */ + PRINTABLE|COMMENT, /* ; */ + PRINTABLE, /* < */ + PRINTABLE, /* = */ + PRINTABLE, /* > */ + PRINTABLE, /* ? */ + PRINTABLE, /* @ */ + PRINTABLE, /* A */ + PRINTABLE, /* B */ + PRINTABLE, /* C */ + PRINTABLE, /* D */ + PRINTABLE, /* E */ + PRINTABLE, /* F */ + PRINTABLE, /* G */ + PRINTABLE, /* H */ + PRINTABLE, /* I */ + PRINTABLE, /* J */ + PRINTABLE, /* K */ + PRINTABLE, /* L */ + PRINTABLE, /* M */ + PRINTABLE, /* N */ + PRINTABLE, /* O */ + PRINTABLE, /* P */ + PRINTABLE, /* Q */ + PRINTABLE, /* R */ + PRINTABLE, /* S */ + PRINTABLE, /* T */ + PRINTABLE, /* U */ + PRINTABLE, /* V */ + PRINTABLE, /* W */ + PRINTABLE, /* X */ + PRINTABLE, /* Y */ + PRINTABLE, /* Z */ + PRINTABLE, /* [ */ + PRINTABLE|BACKSLASH, /* \ */ + PRINTABLE, /* ] */ + PRINTABLE, /* ^ */ + PRINTABLE, /* _ */ + PRINTABLE, /* ` */ + PRINTABLE, /* a */ + PRINTABLE, /* b */ + PRINTABLE, /* c */ + PRINTABLE, /* d */ + PRINTABLE, /* e */ + PRINTABLE, /* f */ + PRINTABLE, /* g */ + PRINTABLE, /* h */ + PRINTABLE, /* i */ + PRINTABLE, /* j */ + PRINTABLE, /* k */ + PRINTABLE, /* l */ + PRINTABLE, /* m */ + PRINTABLE, /* n */ + PRINTABLE, /* o */ + PRINTABLE, /* p */ + PRINTABLE, /* q */ + PRINTABLE, /* r */ + PRINTABLE, /* s */ + PRINTABLE, /* t */ + PRINTABLE, /* u */ + PRINTABLE, /* v */ + PRINTABLE, /* w */ + PRINTABLE, /* x */ + PRINTABLE, /* y */ + PRINTABLE, /* z */ + PRINTABLE, /* { */ + PRINTABLE|VBAR, /* | */ + PRINTABLE, /* } */ + PRINTABLE|TWIDDLE, /* ~ */ + IGNORE, /* ^? */ +}; + +static int lex_unget_c; + +static inline int +lex_get() +{ + int c; + if (lex_unget_c) { + c = lex_unget_c; + lex_unget_c = 0; + } else + c = getchar(); + return c; +} + +static inline void +lex_unget(int c) +{ + if (c != EOF) + lex_unget_c = c; +} + +static int +lex_quoted (void) +{ + int c; + int v; + int count; + + c = lex_get(); +// if (jumping) +// return nil; + if (c == EOF) + return EOF; + c &= 0x7f; + switch (c) { + case 'n': + return '\n'; + case 'f': + return '\f'; + case 'b': + return '\b'; + case 'r': + return '\r'; + case 'v': + return '\v'; + case 't': + return '\t'; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + v = c - '0'; + count = 1; + while (count <= 3) { + c = lex_get(); +// if (jumping) +// return nil; + if (c == EOF) + return EOF; + c &= 0x7f; + if (c < '0' || '7' < c) { + lex_unget(c); + break; + } + v = (v << 3) + c - '0'; + ++count; + } + return v; + default: + return c; + } +} + +static uint16_t lex_class; + +static int +lexc(void) +{ + int c; + do { + c = lex_get(); + if (c == EOF) { + lex_class = ENDOFFILE; + c = 0; + } else { + c &= 0x7f; + lex_class = lex_classes[c]; + if (lex_class & BACKSLASH) { + c = lex_quoted(); + if (c == EOF) + lex_class = ENDOFFILE; + else + lex_class = PRINTABLE; + } + } + } while (lex_class & IGNORE); + return c; +} + +#define AO_LISP_TOKEN_MAX 32 + +static char token_string[AO_LISP_TOKEN_MAX]; +static int token_int; +static int token_len; + +static inline void add_token(int c) { + if (c && token_len < AO_LISP_TOKEN_MAX - 1) + token_string[token_len++] = c; +} + +static inline void end_token(void) { + token_string[token_len] = '\0'; +} + +static int +lex(void) +{ + int c; + + token_len = 0; + for (;;) { + c = lexc(); + if (lex_class & ENDOFFILE) + return AO_LISP_NIL; + +// if (jumping) +// return nil; + if (lex_class & WHITE) + continue; + + if (lex_class & (BRA|KET|QUOTEC)) { + add_token(c); + end_token(); + switch (c) { + case '(': + return OPEN; + case ')': + return CLOSE; + case '\'': + return QUOTE; + } + } + if (lex_class & TWIDDLE) { + token_int = lexc(); + return NUM; + } + if (lex_class & STRINGC) { + for (;;) { + c = lexc(); +// if (jumping) +// return nil; + if (lex_class & (STRINGC|ENDOFFILE)) { + end_token(); + return STRING; + } + add_token(c); + } + } + if (lex_class & PRINTABLE) { + int isnum; + int hasdigit; + int isneg; + + isnum = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isnum = 0; + } else { + if (token_len != 0 && + (lex_class & SIGN)) + { + isnum = 0; + } + if (c == '-') + isneg = 1; + if (lex_class & DIGIT) { + hasdigit = 1; + if (isnum) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); +// if (jumping) +// return nil; + if (lex_class & (NOTNAME)) { +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isnum && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + return NAME; + } + } + + } + } +} + +static int parse_token; +static uint8_t been_here; +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 +read_item(void) +{ + struct ao_lisp_atom *atom; + char *string; + int cons; + ao_lisp_poly v; + + if (!been_here) { + ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); + ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); + ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); + } + + cons = 0; + read_cons = read_cons_tail = read_stack = 0; + for (;;) { + while (parse_token == OPEN) { + if (cons++) + read_stack = ao_lisp_cons(ao_lisp_cons_poly(read_cons), read_stack); + read_cons = NULL; + read_cons_tail = NULL; + parse_token = lex(); + } + + switch (parse_token) { + case ENDOFFILE: + default: + v = AO_LISP_NIL; + break; + case NAME: + atom = ao_lisp_atom_intern(token_string); + if (atom) + v = ao_lisp_atom_poly(atom); + else + v = AO_LISP_NIL; + break; + case NUM: + v = ao_lisp_int_poly(token_int); + break; + case STRING: + string = ao_lisp_string_copy(token_string); + if (string) + v = ao_lisp_string_poly(string); + else + v = AO_LISP_NIL; + break; + case CLOSE: + if (cons) + v = ao_lisp_cons_poly(read_cons); + else + v = AO_LISP_NIL; + if (--cons) { + read_cons = ao_lisp_poly_cons(read_stack->car); + read_stack = read_stack->cdr; + for (read_cons_tail = read_cons; + read_cons_tail && read_cons_tail->cdr; + read_cons_tail = read_cons_tail->cdr) + ; + } + break; + } + + if (!cons) + break; + + struct ao_lisp_cons *read = ao_lisp_cons(v, NULL); + if (read_cons_tail) + read_cons_tail->cdr = read; + else + read_cons = read; + read_cons_tail = read; + + parse_token = lex(); + } + return v; +} + +ao_lisp_poly +ao_lisp_read(void) +{ + parse_token = lex(); + return read_item(); +} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h new file mode 100644 index 00000000..1c994d56 --- /dev/null +++ b/src/lisp/ao_lisp_read.h @@ -0,0 +1,49 @@ +/* + * 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. + */ + +#ifndef _AO_LISP_READ_H_ +#define _AO_LISP_READ_H_ + +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define STRING 5 +# define NUM 6 + +/* + * character classes + */ + +# define PRINTABLE 0x00000001 /* \t \n ' ' - '~' */ +# define QUOTED 0x00000002 /* \ anything */ +# define BRA 0x00000004 /* ( [ { */ +# define KET 0x00000008 /* ) ] } */ +# define WHITE 0x00000010 /* ' ' \t \n */ +# define DIGIT 0x00000020 /* [0-9] */ +# define SIGN 0x00000040 /* +- */ +# define ENDOFFILE 0x00000080 /* end of file */ +# define COMMENT 0x00000100 /* ; # */ +# define IGNORE 0x00000200 /* \0 - ' ' */ +# define QUOTEC 0x00000400 /* ' */ +# define BACKSLASH 0x00000800 /* \ */ +# define VBAR 0x00001000 /* | */ +# define TWIDDLE 0x00002000 /* ~ */ +# define STRINGC 0x00004000 /* " */ + +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NUMBER (DIGIT|SIGN) + +#endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 87024271..1ab56933 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -43,6 +43,18 @@ ao_lisp_string_new(int len) { return a; } +char * +ao_lisp_string_copy(char *a) +{ + int alen = strlen(a); + + char *r = ao_lisp_alloc(alen + 1); + if (!r) + return NULL; + strcpy(r, a); + return r; +} + char * ao_lisp_string_cat(char *a, char *b) { diff --git a/src/test/Makefile b/src/test/Makefile index a409ae13..e841bfde 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -89,7 +89,7 @@ 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_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_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index bbadfa75..96f1fd72 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -23,6 +23,7 @@ main (int argc, char **argv) { 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); @@ -55,4 +56,12 @@ main (int argc, char **argv) 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); + } + } -- 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/test/Makefile') 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 11cb03b1d336ee90c422be27588f57be573a9546 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 22:56:01 -0700 Subject: altos/lisp: Separate out values from atoms This enables changing values of atoms declared as constants, should enable lets, and with some work, even lexical scoping. this required changing the constant computation to run ao_lisp_collect() before dumping the block of constant data, and that uncovered some minor memory manager bugs. Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 105 +++++++++++++++++------ src/lisp/ao_lisp_atom.c | 51 +++++++++-- src/lisp/ao_lisp_builtin.c | 37 ++++++-- src/lisp/ao_lisp_cons.c | 27 +++++- src/lisp/ao_lisp_eval.c | 5 +- src/lisp/ao_lisp_frame.c | 191 ++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 44 ++++++++-- src/lisp/ao_lisp_mem.c | 168 +++++++++++++++++++++++++++++++------ src/lisp/ao_lisp_prim.c | 41 +++++---- src/lisp/ao_lisp_read.c | 23 ++--- src/nucleao-32/Makefile | 3 + src/test/Makefile | 4 +- src/test/ao_lisp_test.c | 3 +- 14 files changed, 597 insertions(+), 108 deletions(-) create mode 100644 src/lisp/ao_lisp_frame.c (limited to 'src/test/Makefile') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index e8c3c02c..9e2fb58c 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -16,7 +16,8 @@ SRCS=\ ao_lisp_poly.c \ ao_lisp_prim.c \ ao_lisp_builtin.c \ - ao_lisp_read.c + ao_lisp_read.c \ + ao_lisp_frame.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d4108662..98e99acb 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -15,9 +15,12 @@ #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 @@ -27,9 +30,14 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define ao_lisp_pool ao_lisp_const +#define AO_LISP_POOL AO_LISP_POOL_CONST #define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) +#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set")) #else #include "ao_lisp_const.h" +#define AO_LISP_POOL 1024 +extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif /* Primitive types */ @@ -46,13 +54,11 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; /* 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_FRAME 6 +#define AO_LISP_NUM_TYPE 7 #define AO_LISP_NIL 0 -#define AO_LISP_POOL 1024 - -extern uint8_t ao_lisp_pool[AO_LISP_POOL]; extern uint16_t ao_lisp_top; #define AO_LISP_OOM 0x01 @@ -68,37 +74,31 @@ 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) + 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)); + return (void *) (AO_LISP_CONST_BASE + (poly & AO_LISP_REF_MASK)); + return (void *) (AO_LISP_POOL_BASE + (poly & AO_LISP_REF_MASK)); } static inline ao_poly ao_lisp_poly(const void *addr, ao_poly type) { const uint8_t *a = addr; - if (addr == NULL) + if (a == 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; - } + if (AO_LISP_IS_CONST(a)) + return AO_LISP_CONST | (a - AO_LISP_CONST_BASE) | type; + return (a - AO_LISP_POOL_BASE) | type; } -#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_type { void (*mark)(void *addr); int (*size)(void *addr); @@ -113,11 +113,32 @@ struct ao_lisp_cons { struct ao_lisp_atom { uint8_t type; uint8_t pad[1]; - ao_poly val; ao_poly next; char name[]; }; +struct ao_lisp_val { + ao_poly atom; + ao_poly val; +}; + +struct ao_lisp_frame { + uint8_t num; + uint8_t readonly; + ao_poly next; + struct ao_lisp_val vals[]; +}; + +static inline struct ao_lisp_frame * +ao_lisp_poly_frame(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_poly(struct ao_lisp_frame *frame) { + return ao_lisp_poly(frame, AO_LISP_OTHER); +} + #define AO_LISP_LAMBDA 0 #define AO_LISP_NLAMBDA 1 #define AO_LISP_MACRO 2 @@ -160,6 +181,11 @@ ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); } +static inline uint8_t +ao_lisp_other_type(void *other) { + return *((uint8_t *) other); +} + static inline ao_poly ao_lisp_other_poly(const void *other) { @@ -175,9 +201,9 @@ ao_lisp_mem_round(int size) #define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & 3; + int type = poly & AO_LISP_TYPE_MASK; if (type == AO_LISP_OTHER) - return *((uint8_t *) ao_lisp_poly_other(poly)); + return ao_lisp_other_type(ao_lisp_poly_other(poly)); return type; } @@ -249,6 +275,9 @@ ao_lisp_mark(const struct ao_lisp_type *type, void *addr); int ao_lisp_mark_memory(void *addr, int size); +void * +ao_lisp_move_map(void *addr); + void * ao_lisp_move(const struct ao_lisp_type *type, void *addr); @@ -259,6 +288,9 @@ ao_lisp_move_memory(void *addr, int size); void * ao_lisp_alloc(int size); +void +ao_lisp_collect(void); + int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr); @@ -303,6 +335,12 @@ ao_lisp_atom_print(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); +ao_poly +ao_lisp_atom_get(ao_poly atom); + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val); + /* int */ void ao_lisp_int_print(ao_poly i); @@ -325,6 +363,8 @@ ao_lisp_eval(ao_poly p); void ao_lisp_builtin_print(ao_poly b); +extern const struct ao_lisp_type ao_lisp_builtin_type; + /* read */ ao_poly ao_lisp_read(void); @@ -333,4 +373,19 @@ ao_lisp_read(void); ao_poly ao_lisp_read_eval_print(void); +/* frame */ +extern const struct ao_lisp_type ao_lisp_frame_type; + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom); + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly); + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index aaa84b8d..e5d28c3b 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -17,6 +17,12 @@ #include "ao_lisp.h" +#if 0 +#define DBG(...) printf(__VA_ARGS__) +#else +#define DBG(...) +#endif + static int name_size(char *name) { return sizeof(struct ao_lisp_atom) + strlen(name) + 1; @@ -34,31 +40,38 @@ static void atom_mark(void *addr) { struct ao_lisp_atom *atom = addr; + DBG ("\tatom start %s\n", atom->name); for (;;) { - ao_lisp_poly_mark(atom->val); atom = ao_lisp_poly_atom(atom->next); if (!atom) break; + DBG("\t\tatom mark %s %d\n", atom->name, (uint8_t *) atom - ao_lisp_const); if (ao_lisp_mark_memory(atom, atom_size(atom))) break; } + DBG ("\tatom done\n"); } static void atom_move(void *addr) { struct ao_lisp_atom *atom = addr; + DBG("\tatom move start %s %d next %s %d\n", + atom->name, ((uint8_t *) atom - ao_lisp_const), + atom->next ? ao_lisp_poly_atom(atom->next)->name : "(none)", + atom->next ? ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const) : 0); for (;;) { struct ao_lisp_atom *next; - atom->val = ao_lisp_poly_move(atom->val); next = ao_lisp_poly_atom(atom->next); next = ao_lisp_move_memory(next, atom_size(next)); if (!next) break; + DBG("\t\tatom move %s %d->%d\n", next->name, ((uint8_t *) ao_lisp_poly_atom(atom->next) - ao_lisp_const), ((uint8_t *) next - ao_lisp_const)); atom->next = ao_lisp_atom_poly(next); atom = next; } + DBG("\tatom move end\n"); } const struct ao_lisp_type ao_lisp_atom_type = { @@ -73,7 +86,6 @@ struct ao_lisp_atom * ao_lisp_atom_intern(char *name) { struct ao_lisp_atom *atom; -// int b; for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { if (!strcmp(atom->name, name)) @@ -85,19 +97,46 @@ ao_lisp_atom_intern(char *name) return atom; } #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 = ao_lisp_atom_poly(ao_lisp_atoms); + if (!ao_lisp_atoms) + ao_lisp_root_add(&ao_lisp_atom_type, &ao_lisp_atoms); ao_lisp_atoms = atom; strcpy(atom->name, name); - atom->val = AO_LISP_NIL; } return atom; } +static struct ao_lisp_frame *globals; + +ao_poly +ao_lisp_atom_get(ao_poly atom) +{ + struct ao_lisp_frame *frame = globals; +#ifdef ao_builtin_frame + if (!frame) + frame = ao_lisp_poly_frame(ao_builtin_frame); +#endif + return ao_lisp_frame_get(frame, atom); +} + +ao_poly +ao_lisp_atom_set(ao_poly atom, ao_poly val) +{ + if (!ao_lisp_frame_set(globals, atom, val)) { + globals = ao_lisp_frame_add(globals, atom, val); + if (!globals->next) { + ao_lisp_root_add(&ao_lisp_frame_type, &globals); +#ifdef ao_builtin_frame + globals->next = ao_builtin_frame; +#endif + } + } + return val; +} + void ao_lisp_atom_print(ao_poly a) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 63fb69fd..8c481793 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,31 @@ #include "ao_lisp.h" +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + void ao_lisp_builtin_print(ao_poly b) { @@ -120,20 +145,12 @@ ao_lisp_quote(struct ao_lisp_cons *cons) ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - ao_poly atom, val; if (!check_argc(cons, 2, 2)) return AO_LISP_NIL; if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - atom = cons->car; - val = ao_lisp_poly_cons(cons->cdr)->car; - if (ao_lisp_is_const(atom)) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - ao_lisp_poly_atom(atom)->val = val; - return val; + return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); } ao_poly @@ -157,6 +174,8 @@ ao_lisp_print(struct ao_lisp_cons *cons) val = cons->car; ao_lisp_poly_print(val); cons = ao_lisp_poly_cons(cons->cdr); + if (cons) + printf(" "); } return val; } diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 65908e30..f8a34ed4 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -14,6 +14,23 @@ #include "ao_lisp.h" +#define OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_const)) + +#if 0 +static int cons_depth; +#define DBG(...) do { int d; for (d = 0; d < cons_depth; d++) printf (" "); printf(__VA_ARGS__); } while(0) +#define DBG_IN() (cons_depth++) +#define DBG_OUT() (cons_depth--) +#define DBG_PR(c) ao_lisp_cons_print(ao_lisp_cons_poly(c)) +#define DBG_PRP(p) ao_lisp_poly_print(p) +#else +#define DBG(...) +#define DBG_IN() +#define DBG_OUT() +#define DBG_PR(c) +#define DBG_PRP(p) +#endif + static void cons_mark(void *addr) { struct ao_lisp_cons *cons = addr; @@ -38,17 +55,25 @@ static void cons_move(void *addr) { struct ao_lisp_cons *cons = addr; + DBG_IN(); + DBG("move cons start %d\n", OFFSET(cons)); for (;;) { struct ao_lisp_cons *cdr; + ao_poly car; - cons->car = ao_lisp_poly_move(cons->car); + car = ao_lisp_poly_move(cons->car); + DBG(" moved car %d -> %d\n", OFFSET(ao_lisp_ref(cons->car)), OFFSET(ao_lisp_ref(car))); + cons->car = car; cdr = ao_lisp_poly_cons(cons->cdr); cdr = ao_lisp_move_memory(cdr, sizeof (struct ao_lisp_cons)); if (!cdr) break; + DBG(" moved cdr %d -> %d\n", OFFSET(ao_lisp_poly_cons(cons->cdr)), OFFSET(cdr)); cons->cdr = ao_lisp_cons_poly(cdr); cons = cdr; } + DBG("move cons end\n"); + DBG_OUT(); } const struct ao_lisp_type ao_lisp_cons_type = { diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 2374fdb2..6eef1f23 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -91,7 +91,7 @@ ao_lisp_eval(ao_poly v) case AO_LISP_STRING: break; case AO_LISP_ATOM: - v = ao_lisp_poly_atom(v)->val; + v = ao_lisp_atom_get(v); break; } @@ -187,6 +187,9 @@ ao_lisp_eval(ao_poly v) DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { + actuals = 0; + formals = 0; + formals_tail = 0; DBG("done func\n"); break; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c new file mode 100644 index 00000000..5aa50f6b --- /dev/null +++ b/src/lisp/ao_lisp_frame.c @@ -0,0 +1,191 @@ +/* + * 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 + +static inline int +frame_num_size(int num) +{ + return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); +} + +static int +frame_size(void *addr) +{ + struct ao_lisp_frame *frame = addr; + return frame_num_size(frame->num); +} + +#define OFFSET(a) ((uint8_t *) (ao_lisp_ref(a)) - ao_lisp_const) + +static void +frame_mark(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + + ao_lisp_poly_mark(v->atom); + ao_lisp_poly_mark(v->val); + DBG ("\tframe mark atom %s %d val %d at %d\n", ao_lisp_poly_atom(v->atom)->name, OFFSET(v->atom), OFFSET(v->val), f); + } + frame = ao_lisp_poly_frame(frame->next); + if (!frame) + break; + if (ao_lisp_mark_memory(frame, frame_size(frame))) + break; + } +} + +static void +frame_move(void *addr) +{ + struct ao_lisp_frame *frame = addr; + int f; + + for (;;) { + struct ao_lisp_frame *next; + if (frame->readonly) + break; + for (f = 0; f < frame->num; f++) { + struct ao_lisp_val *v = &frame->vals[f]; + ao_poly t; + + t = ao_lisp_poly_move(v->atom); + DBG("\t\tatom %s %d -> %d\n", ao_lisp_poly_atom(t)->name, OFFSET(v->atom), OFFSET(t)); + v->atom = t; + t = ao_lisp_poly_move(v->val); + DBG("\t\tval %d -> %d\n", OFFSET(v->val), OFFSET(t)); + v->val = t; + } + next = ao_lisp_poly_frame(frame->next); + if (!next) + break; + next = ao_lisp_move_memory(next, frame_size(next)); + frame->next = ao_lisp_frame_poly(next); + frame = next; + } +} + +const struct ao_lisp_type ao_lisp_frame_type = { + .mark = frame_mark, + .size = frame_size, + .move = frame_move +}; + +static ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + int f; + for (f = 0; f < frame->num; f++) + if (frame->vals[f].atom == atom) + return &frame->vals[f].val; + return NULL; +} + +int +ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + while (frame) { + if (!frame->readonly) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) { + *ref = val; + return 1; + } + } + frame = ao_lisp_poly_frame(frame->next); + } + return 0; +} + +ao_poly +ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +{ + while (frame) { + ao_poly *ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return *ref; + frame = ao_lisp_poly_frame(frame->next); + } + return AO_LISP_NIL; +} + +struct ao_lisp_frame * +ao_lisp_frame_new(int num, int readonly) +{ + struct ao_lisp_frame *frame = ao_lisp_alloc(frame_num_size(num)); + + if (!frame) + return NULL; + frame->num = num; + frame->readonly = readonly; + frame->next = AO_LISP_NIL; + memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + return frame; +} + +static struct ao_lisp_frame * +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num, int readonly) +{ + struct ao_lisp_frame *new; + int copy; + + if (new_num == frame->num) + return frame; + new = ao_lisp_frame_new(new_num, readonly); + if (!new) + return NULL; + copy = new_num; + if (copy > frame->num) + copy = frame->num; + memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); + if (frame) + new->next = frame->next; + return new; +} + +struct ao_lisp_frame * +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) +{ + ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; + if (!ref) { + int f; + if (frame) { + f = frame->num; + frame = ao_lisp_frame_realloc(frame, f + 1, frame->readonly); + } else { + f = 0; + frame = ao_lisp_frame_new(1, 0); + } + if (!frame) + return NULL; + DBG ("add atom %s %d, val %d at %d\n", ao_lisp_poly_atom(atom)->name, OFFSET(atom), OFFSET(val), f); + frame->vals[f].atom = atom; + ref = &frame->vals[f].val; + } + *ref = val; + return frame; +} diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 8d3e03a9..6b603979 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -49,19 +49,43 @@ struct builtin_func funcs[] = { #define N_FUNC (sizeof funcs / sizeof funcs[0]) +struct ao_lisp_frame *globals; + +static int +is_atom(int offset) +{ + struct ao_lisp_atom *a; + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) + if (((uint8_t *) a->name - ao_lisp_const) == offset) + return strlen(a->name); + return 0; +} + int main(int argc, char **argv) { int f, o; ao_poly atom, val; struct ao_lisp_atom *a; + int in_atom; + printf("/*\n"); + printf(" * Generated file, do not edit\n"); + ao_lisp_root_add(&ao_lisp_frame_type, &globals); + globals = ao_lisp_frame_new(0, 0); for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); - a->val = ao_lisp_builtin_poly(b); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* boolean constants */ + a = ao_lisp_atom_intern("nil"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + a = ao_lisp_atom_intern("t"); + globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + for (;;) { atom = ao_lisp_read(); if (!atom) @@ -73,13 +97,19 @@ main(int argc, char **argv) fprintf(stderr, "input must be atom val pairs\n"); exit(1); } - ao_lisp_poly_atom(atom)->val = val; + globals = ao_lisp_frame_add(globals, atom, val); } - printf("/* constant objects, all referenced from atoms */\n\n"); + /* Reduce to referenced values */ + ao_lisp_collect(); + printf(" */\n"); + + globals->readonly = 1; + 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("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; @@ -101,10 +131,14 @@ main(int argc, char **argv) else printf(" "); c = ao_lisp_const[o]; - if (' ' < c && c <= '~' && c != '\'') + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { printf (" '%c',", c); - else + in_atom--; + } else { printf("0x%02x,", c); + } } 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 7295d150..27f5b666 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -17,11 +17,32 @@ #include "ao_lisp.h" #include -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))); +#define ao_lisp_pool ao_lisp_const +#undef AO_LISP_POOL +#define AO_LISP_POOL AO_LISP_POOL_CONST +#else +uint8_t ao_lisp_pool[AO_LISP_POOL] __attribute__((aligned(4))); +#endif + +#if 0 +#define DBG_DUMP +#define DBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define DBG(...) printf(__VA_ARGS__) +static int move_dump; +static int move_depth; +#define DBG_RESET() (move_depth = 0) +#define DBG_MOVE(...) do { if(move_dump) { int d; for (d = 0; d < move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) +#define DBG_MOVE_IN() (move_depth++) +#define DBG_MOVE_OUT() (move_depth--) +#else +#define DBG(...) +#define DBG_RESET() +#define DBG_MOVE(...) +#define DBG_MOVE_IN() +#define DBG_MOVE_OUT() #endif uint8_t ao_lisp_exception; @@ -112,6 +133,23 @@ clear_object(uint8_t *tag, void *addr, int size) { return 0; } +static int +busy_object(uint8_t *tag, void *addr) { + int base; + + 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; + base = limit(base); + if (busy(tag, base)) + return 1; + return 0; +} + static void *move_old, *move_new; static int move_size; @@ -120,53 +158,96 @@ move_object(void) { int i; + DBG_RESET(); + DBG_MOVE("move %d -> %d\n", DBG_OFFSET(move_old), DBG_OFFSET(move_new)); + DBG_MOVE_IN(); memset(ao_lisp_moving, '\0', sizeof (ao_lisp_moving)); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) { + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { void *new; + DBG_MOVE("root %d\n", DBG_OFFSET(*ao_lisp_root[i].addr)); new = ao_lisp_move(ao_lisp_root[i].type, *ao_lisp_root[i].addr); if (new) *ao_lisp_root[i].addr = new; } + DBG_MOVE_OUT(); + DBG_MOVE("move done\n"); } +#ifdef DBG_DUMP static void -collect(void) +dump_busy(void) +{ + int i; + printf("busy:"); + for (i = 0; i < ao_lisp_top; i += 4) { + if ((i & 0xff) == 0) + printf("\n"); + else if ((i & 0x1f) == 0) + printf(" "); + if (busy(ao_lisp_busy, i)) + putchar('*'); + else + putchar('-'); + } + printf ("\n"); +} +#define DUMP_BUSY() dump_busy() +#else +#define DUMP_BUSY() +#endif + +void +ao_lisp_collect(void) { int i; + int top; /* Mark */ memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); + DBG("mark\n"); for (i = 0; i < AO_LISP_ROOT; i++) - if (ao_lisp_root[i].addr) + if (ao_lisp_root[i].addr && *ao_lisp_root[i].addr) { + DBG("root %p\n", *ao_lisp_root[i].addr); ao_lisp_mark(ao_lisp_root[i].type, *ao_lisp_root[i].addr); + } + DUMP_BUSY(); /* Compact */ - ao_lisp_top = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { + DBG("find first busy\n"); + for (i = 0; i < ao_lisp_top; i += 4) { if (!busy(ao_lisp_busy, i)) break; } - ao_lisp_top = i; - while(i < AO_LISP_POOL) { + top = i; + while(i < ao_lisp_top) { if (busy(ao_lisp_busy, i)) { + DBG("busy %d -> %d\n", i, top); move_old = &ao_lisp_pool[i]; - move_new = &ao_lisp_pool[ao_lisp_top]; + move_new = &ao_lisp_pool[top]; move_size = 0; move_object(); + DBG("\tbusy size %d\n", move_size); + if (move_size == 0) + abort(); clear_object(ao_lisp_busy, move_old, move_size); + mark_object(ao_lisp_busy, move_new, move_size); i += move_size; - ao_lisp_top += move_size; + top += move_size; + DUMP_BUSY(); } else { i += 4; } } + ao_lisp_top = top; } void ao_lisp_mark(const struct ao_lisp_type *type, void *addr) { + if (!addr) + return; if (mark_object(ao_lisp_busy, addr, type->size(addr))) return; type->mark(addr); @@ -178,12 +259,32 @@ ao_lisp_mark_memory(void *addr, int size) return mark_object(ao_lisp_busy, addr, size); } +/* + * After the object has been moved, we have to reference it + * in the new location. This is only relevant for ao_lisp_poly_move + * as it needs to fetch the type byte from the object, which + * may have been overwritten by the copy + */ +void * +ao_lisp_move_map(void *addr) +{ + if (addr == move_old) { + if (busy_object(ao_lisp_moving, addr)) + return move_new; + } + return addr; +} + static void * check_move(void *addr, int size) { if (addr == move_old) { - memmove(move_new, move_old, size); - move_size = (size + 3) & ~3; + DBG_MOVE("mapping %d -> %d\n", DBG_OFFSET(addr), DBG_OFFSET(move_new)); + if (!busy_object(ao_lisp_moving, addr)) { + DBG_MOVE(" copy %d\n", size); + memmove(move_new, move_old, size); + move_size = (size + 3) & ~3; + } addr = move_new; } return addr; @@ -192,15 +293,32 @@ check_move(void *addr, int size) void * ao_lisp_move(const struct ao_lisp_type *type, void *addr) { + uint8_t *a = addr; int size = type->size(addr); if (!addr) return NULL; +#ifndef AO_LISP_MAKE_CONST + if (AO_LISP_IS_CONST(addr)) + return addr; +#endif + DBG_MOVE("object %d\n", DBG_OFFSET(addr)); + if (a < ao_lisp_pool || ao_lisp_pool + AO_LISP_POOL <= a) + abort(); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); return addr; + } + DBG_MOVE_OUT(); + DBG_MOVE("recursing...\n"); + DBG_MOVE_IN(); type->move(addr); + DBG_MOVE_OUT(); + DBG_MOVE("done %d\n", DBG_OFFSET(addr)); return addr; } @@ -210,9 +328,15 @@ ao_lisp_move_memory(void *addr, int size) if (!addr) return NULL; + DBG_MOVE("memory %d\n", DBG_OFFSET(addr)); + DBG_MOVE_IN(); addr = check_move(addr, size); - if (mark_object(ao_lisp_moving, addr, size)) - return NULL; + if (mark_object(ao_lisp_moving, addr, size)) { + DBG_MOVE("already moved\n"); + DBG_MOVE_OUT(); + return addr; + } + DBG_MOVE_OUT(); return addr; } @@ -222,22 +346,14 @@ ao_lisp_alloc(int size) void *addr; 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(); + ao_lisp_collect(); 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; } @@ -246,6 +362,7 @@ int ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) { int i; + DBG("add root type %p addr %p\n", type, addr); for (i = 0; i < AO_LISP_ROOT; i++) { if (!ao_lisp_root[i].addr) { ao_lisp_root[i].addr = addr; @@ -253,6 +370,7 @@ ao_lisp_root_add(const struct ao_lisp_type *type, void *addr) return 1; } } + abort(); return 0; } diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 38dcb961..e9367553 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -31,35 +31,32 @@ ao_lisp_poly_print(ao_poly p) return p; } +static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { + [AO_LISP_CONS] = &ao_lisp_cons_type, + [AO_LISP_STRING] = &ao_lisp_string_type, + [AO_LISP_ATOM] = &ao_lisp_atom_type, + [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, +}; + void ao_lisp_poly_mark(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - ao_lisp_mark(&ao_lisp_cons_type, ao_lisp_poly_cons(p)); - break; - case AO_LISP_STRING: - ao_lisp_mark(&ao_lisp_string_type, ao_lisp_poly_string(p)); - break; - case AO_LISP_ATOM: - ao_lisp_mark(&ao_lisp_atom_type, ao_lisp_poly_atom(p)); - break; - } + const struct ao_lisp_type *lisp_type = ao_lisp_types[ao_lisp_poly_type(p)]; + if (lisp_type) + ao_lisp_mark(lisp_type, ao_lisp_ref(p)); } ao_poly ao_lisp_poly_move(ao_poly p) { - switch (ao_lisp_poly_type(p)) { - case AO_LISP_CONS: - p = ao_lisp_cons_poly(ao_lisp_move(&ao_lisp_cons_type, ao_lisp_poly_cons(p))); - break; - case AO_LISP_STRING: - p = ao_lisp_string_poly(ao_lisp_move(&ao_lisp_string_type, ao_lisp_poly_string(p))); - break; - case AO_LISP_ATOM: - p = ao_lisp_atom_poly(ao_lisp_move(&ao_lisp_atom_type, ao_lisp_poly_atom(p))); - break; - } + uint8_t type = p & AO_LISP_TYPE_MASK; + const struct ao_lisp_type *lisp_type; + + if (type == AO_LISP_OTHER) + type = ao_lisp_other_type(ao_lisp_move_map(ao_lisp_poly_other(p))); + + lisp_type = ao_lisp_types[type]; + if (lisp_type) + p = ao_lisp_poly(ao_lisp_move(lisp_type, ao_lisp_ref(p)), p & AO_LISP_TYPE_MASK); return p; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8fc134e5..bc1eb36b 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -188,8 +188,6 @@ lex_quoted (void) int count; c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -218,8 +216,6 @@ lex_quoted (void) count = 1; while (count <= 3) { c = lex_get(); -// if (jumping) -// return nil; if (c == EOF) return EOF; c &= 0x7f; @@ -288,11 +284,17 @@ lex(void) if (lex_class & ENDOFFILE) return AO_LISP_NIL; -// if (jumping) -// return nil; if (lex_class & WHITE) continue; + if (lex_class & COMMENT) { + while ((c = lexc()) != '\n') { + if (lex_class & ENDOFFILE) + return AO_LISP_NIL; + } + continue; + } + if (lex_class & (BRA|KET|QUOTEC)) { add_token(c); end_token(); @@ -312,8 +314,6 @@ lex(void) if (lex_class & STRINGC) { for (;;) { c = lexc(); -// if (jumping) -// return nil; if (lex_class & (STRINGC|ENDOFFILE)) { end_token(); return STRING; @@ -349,8 +349,6 @@ lex(void) } add_token (c); c = lexc (); -// if (jumping) -// return nil; if (lex_class & (NOTNAME)) { // if (lex_class & ENDOFFILE) // clearerr (f); @@ -403,6 +401,10 @@ pop_read_stack(int cons) read_cons_tail && read_cons_tail->cdr; read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) ; + } else { + read_cons = 0; + read_cons_tail = 0; + read_stack = 0; } return in_quote; } @@ -420,6 +422,7 @@ ao_lisp_read(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons); ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); + been_here = 1; } parse_token = lex(); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 0df44317..1b7e0bb0 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -13,6 +13,8 @@ INC = \ ao_pins.h \ ao_product.h \ ao_task.h \ + ao_lisp.h \ + ao_lisp_const.h \ stm32f0.h \ Makefile @@ -43,6 +45,7 @@ ALTOS_SRC = \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ + ao_lisp_frame.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/test/Makefile b/src/test/Makefile index 6c51c421..bd195161 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -91,7 +91,9 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h #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_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ + ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ + ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 810a1528..e303869f 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -36,7 +36,6 @@ main (int argc, char **argv) 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_cons(ao_lisp_atom_poly(atom), list); } ao_lisp_poly_print(ao_lisp_cons_poly(list)); @@ -45,7 +44,7 @@ main (int argc, char **argv) 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); + ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } #if 1 -- cgit v1.2.3 From 77db0e8162cd01c2b42737b3d71b38cea942484f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 3 Nov 2016 21:49:50 -0700 Subject: altos: Add lambda support to lisp Signed-off-by: Keith Packard --- src/lisp/Makefile | 3 +- src/lisp/ao_lisp.h | 51 ++++-- src/lisp/ao_lisp_atom.c | 62 +++++-- src/lisp/ao_lisp_builtin.c | 123 +++++++------- src/lisp/ao_lisp_const.lisp | 3 + src/lisp/ao_lisp_error.c | 29 ++++ src/lisp/ao_lisp_eval.c | 368 +++++++++++++++++++++++++++++++++++------- src/lisp/ao_lisp_frame.c | 2 +- src/lisp/ao_lisp_make_const.c | 29 +++- src/lisp/ao_lisp_rep.c | 6 - src/nucleao-32/Makefile | 1 + src/nucleao-32/ao_pins.h | 2 + src/test/Makefile | 3 +- src/test/ao_lisp_test.c | 11 +- 14 files changed, 528 insertions(+), 165 deletions(-) create mode 100644 src/lisp/ao_lisp_error.c (limited to 'src/test/Makefile') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 9e2fb58c..be19b432 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -17,7 +17,8 @@ SRCS=\ ao_lisp_prim.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ - ao_lisp_frame.c + ao_lisp_frame.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 98e99acb..9a5cc63e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -32,11 +32,22 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST -#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) -#define _ao_lisp_atom_set ao_lisp_atom_poly(ao_lisp_atom_intern("set")) + +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) + +#define _ao_lisp_atom_quote _atom("quote") +#define _ao_lisp_atom_set _atom("set") +#define _ao_lisp_atom_setq _atom("setq") +#define _ao_lisp_atom_t _atom("t") +#define _ao_lisp_atom_car _atom("car") +#define _ao_lisp_atom_cdr _atom("cdr") +#define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_cond _atom("cond") #else #include "ao_lisp_const.h" +#ifndef AO_LISP_POOL #define AO_LISP_POOL 1024 +#endif extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #endif @@ -68,6 +79,7 @@ extern uint16_t ao_lisp_top; extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; static inline int ao_lisp_is_const(ao_poly poly) { @@ -157,6 +169,7 @@ enum ao_lisp_builtin_id { builtin_quote, builtin_set, builtin_setq, + builtin_cond, builtin_print, builtin_plus, builtin_minus, @@ -222,13 +235,13 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) static inline int ao_lisp_poly_int(ao_poly poly) { - return (int) poly >> AO_LISP_TYPE_SHIFT; + return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly ao_lisp_int_poly(int i) { - return ((ao_poly) i << 2) + AO_LISP_INT; + return ((ao_poly) i << 2) | AO_LISP_INT; } static inline char * @@ -326,8 +339,7 @@ extern const struct ao_lisp_type ao_lisp_atom_type; extern struct ao_lisp_atom *ao_lisp_atoms; -void -ao_lisp_atom_init(void); +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -359,12 +371,27 @@ ao_lisp_poly_move(ao_poly p); ao_poly ao_lisp_eval(ao_poly p); +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *cons); + /* builtin */ void ao_lisp_builtin_print(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; +/* Check argument count */ +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); + +/* Check argument type */ +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); + +/* Fetch an arg (nil if off the end) */ +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc); + /* read */ ao_poly ao_lisp_read(void); @@ -376,11 +403,8 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom); +ao_poly * +ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); struct ao_lisp_frame * ao_lisp_frame_new(int num, int readonly); @@ -388,4 +412,9 @@ ao_lisp_frame_new(int num, int readonly); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +/* error */ + +ao_poly +ao_lisp_error(int error, char *format, ...); + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index e5d28c3b..ea04741e 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -109,31 +109,65 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *globals; +static struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +static void +ao_lisp_atom_init(void) +{ + if (!ao_lisp_frame_global) { + ao_lisp_frame_global = ao_lisp_frame_new(0, 0); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_global); + ao_lisp_root_add(&ao_lisp_frame_type, &ao_lisp_frame_current); + } +} + +static ao_poly * +ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +{ + ao_poly *ref; + ao_lisp_atom_init(); + while (frame) { + ref = ao_lisp_frame_ref(frame, atom); + if (ref) + return ref; + frame = ao_lisp_poly_frame(frame->next); + } + if (ao_lisp_frame_global) { + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + return ref; + } + return NULL; +} ao_poly ao_lisp_atom_get(ao_poly atom) { - struct ao_lisp_frame *frame = globals; + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); #ifdef ao_builtin_frame - if (!frame) - frame = ao_lisp_poly_frame(ao_builtin_frame); + if (!ref) + ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); #endif - return ao_lisp_frame_get(frame, atom); + if (ref) + return *ref; + return AO_LISP_NIL; } ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val) { - if (!ao_lisp_frame_set(globals, atom, val)) { - globals = ao_lisp_frame_add(globals, atom, val); - if (!globals->next) { - ao_lisp_root_add(&ao_lisp_frame_type, &globals); -#ifdef ao_builtin_frame - globals->next = ao_builtin_frame; -#endif - } - } + ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + + if (!ref && ao_lisp_frame_global) + ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); + if (ref) + *ref = val; + else + ao_lisp_frame_global = ao_lisp_frame_add(ao_lisp_frame_global, atom, val); return val; } diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 8c481793..2976bc95 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -46,7 +46,8 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } -static int check_argc(struct ao_lisp_cons *cons, int min, int max) +ao_poly +ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) { int argc = 0; @@ -54,28 +55,30 @@ static int check_argc(struct ao_lisp_cons *cons, int min, int max) argc++; cons = ao_lisp_poly_cons(cons->cdr); } - if (argc < min || argc > max) { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; - } - return 1; + if (argc < min || argc > max) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); + return _ao_lisp_atom_t; } -static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +ao_poly +ao_lisp_arg(struct ao_lisp_cons *cons, int argc) { - ao_poly car; - - /* find the desired arg */ - while (argc--) + while (argc--) { + if (!cons) + return AO_LISP_NIL; cons = ao_lisp_poly_cons(cons->cdr); - car = cons->car; - if ((!car && !nil_ok) || - ao_lisp_poly_type(car) != type) - { - ao_lisp_exception |= AO_LISP_INVALID; - return 0; } - return 1; + return cons->car; +} + +ao_poly +ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_lisp_arg(cons, argc); + + if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); + return _ao_lisp_atom_t; } enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; @@ -83,30 +86,20 @@ enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->car; } ao_poly ao_lisp_cdr(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) return AO_LISP_NIL; - } return ao_lisp_poly_cons(cons->car)->cdr; } @@ -114,50 +107,39 @@ ao_poly ao_lisp_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - car = cons->car; - cdr = cons->cdr; - if (!car || !cdr) { - ao_lisp_exception |= AO_LISP_INVALID; + if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - } - cdr = ao_lisp_poly_cons(cdr)->car; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) return AO_LISP_NIL; - } + car = ao_lisp_arg(cons, 0); + cdr = ao_lisp_arg(cons, 1); return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; - } - return cons->car; + return ao_lisp_arg(cons, 0); } ao_poly ao_lisp_set(struct ao_lisp_cons *cons) { - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; - if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) return AO_LISP_NIL; - return ao_lisp_atom_set(cons->car, ao_lisp_poly_cons(cons->cdr)->car); + return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_poly_cons(ao_lisp_arg(cons, 1))->car); } ao_poly ao_lisp_setq(struct ao_lisp_cons *cons) { struct ao_lisp_cons *expand = 0; - if (!check_argc(cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; expand = ao_lisp_cons_cons(_ao_lisp_atom_set, ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, @@ -166,6 +148,22 @@ ao_lisp_setq(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(expand); } +ao_poly +ao_lisp_cond(struct ao_lisp_cons *cons) +{ + int argc; + struct ao_lisp_cons *arg; + + argc = 0; + for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { + if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", + ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); + } + ao_lisp_set_cond(cons); + return AO_LISP_NIL; +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -210,17 +208,13 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) r *= c; break; case math_divide: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; case math_mod: - if (c == 0) { - ao_lisp_exception |= AO_LISP_DIVIDE_BY_ZERO; - return AO_LISP_NIL; - } + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); r %= c; break; } @@ -230,10 +224,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum math_op op) else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == math_plus) ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), ao_lisp_poly_string(car))); - else { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } + else + return ao_lisp_error(AO_LISP_INVALID, "invalid args"); } return ret; } @@ -275,6 +267,7 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, + [builtin_cond] = ao_lisp_cond, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index aa356d45..5ee15899 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1 +1,4 @@ cadr (lambda (l) (car (cdr l))) +list (lexpr (l) l) +1+ (lambda (x) (+ x 1)) +1- (lambda (x) (- x 1)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c new file mode 100644 index 00000000..ea8111d9 --- /dev/null +++ b/src/lisp/ao_lisp_error.c @@ -0,0 +1,29 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +ao_poly +ao_lisp_error(int error, char *format, ...) +{ + va_list args; + + ao_lisp_exception |= error; + va_start(args, format); + vprintf(format, args); + va_end(args); + printf("\n"); + return AO_LISP_NIL; +} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 6eef1f23..803f1e2e 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -14,32 +14,238 @@ #include "ao_lisp.h" -/* - * Non-recursive eval - * - * Plan: walk actuals, construct formals - * - * stack > save > actuals > actual_1 - * v v - * formals . > actual_2 - */ - -static struct ao_lisp_cons *stack; -static struct ao_lisp_cons *actuals; -static struct ao_lisp_cons *formals; -static struct ao_lisp_cons *formals_tail; -static uint8_t been_here; - #if 0 #define DBG(...) printf(__VA_ARGS__) -#define DBG_CONS(a) ao_lisp_cons_print(a) +#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_print(a) +#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) #else #define DBG(...) #define DBG_CONS(a) #define DBG_POLY(a) #endif +struct ao_lisp_stack { + ao_poly next; + ao_poly actuals; + ao_poly formals; + ao_poly frame; + ao_poly cond; +}; + +static struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static ao_poly +ao_lisp_stack_poly(struct ao_lisp_stack *stack) +{ + return ao_lisp_poly(stack, AO_LISP_OTHER); +} + +static int +stack_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_stack); +} + +static void +stack_mark(void *addr) +{ + struct ao_lisp_stack *stack = addr; + for (;;) { + ao_lisp_poly_mark(stack->actuals); + ao_lisp_poly_mark(stack->formals); + ao_lisp_poly_mark(stack->frame); + ao_lisp_poly_mark(stack->cond); + stack = ao_lisp_poly_stack(stack->next); + if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) + break; + } +} + +static void +stack_move(void *addr) +{ + struct ao_lisp_stack *stack = addr; + + for (;;) { + struct ao_lisp_stack *next; + stack->actuals = ao_lisp_poly_move(stack->actuals); + stack->formals = ao_lisp_poly_move(stack->formals); + stack->frame = ao_lisp_poly_move(stack->frame); + stack->cond = ao_lisp_poly_move(stack->cond); + next = ao_lisp_ref(stack->next); + next = ao_lisp_move_memory(next, sizeof (struct ao_lisp_stack)); + stack->next = ao_lisp_stack_poly(next); + stack = next; + } +} + +static const struct ao_lisp_type ao_lisp_stack_type = { + .size = stack_size, + .mark = stack_mark, + .move = stack_move +}; + + +static struct ao_lisp_stack *stack; +static struct ao_lisp_cons *actuals; +static struct ao_lisp_cons *formals; +static struct ao_lisp_cons *formals_tail; +static struct ao_lisp_cons *cond; +struct ao_lisp_frame *next_frame; +static uint8_t been_here; + +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + cond = c; + return AO_LISP_NIL; +} + +static int +ao_lisp_stack_push(void) +{ + struct ao_lisp_stack *n = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); + if (!n) + return 0; + n->next = ao_lisp_stack_poly(stack); + n->actuals = ao_lisp_cons_poly(actuals); + n->formals = ao_lisp_cons_poly(formals); + n->cond = ao_lisp_cons_poly(cond); + n->frame = ao_lisp_frame_poly(ao_lisp_frame_current); + DBG("push frame %d\n", OFFSET(ao_lisp_frame_current)); + stack = n; + return 1; +} + +static void +ao_lisp_stack_pop(void) +{ + actuals = ao_lisp_poly_cons(stack->actuals); + formals = ao_lisp_poly_cons(stack->formals); + cond = ao_lisp_poly_cons(stack->cond); + ao_lisp_frame_current = ao_lisp_poly_frame(stack->frame); + DBG("pop frame %d\n", OFFSET(ao_lisp_frame_current)); + formals_tail = 0; + + /* Recompute the tail of the formals list */ + if (formals) { + struct ao_lisp_cons *formal; + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); + formals_tail = formal; + } + stack = ao_lisp_poly_stack(stack->next); +} + +static void +ao_lisp_stack_clear(void) +{ + stack = 0; + actuals = formals = formals_tail = 0; + cond = 0; + ao_lisp_frame_current = 0; +} + + +static ao_poly +func_type(ao_poly func) +{ + struct ao_lisp_cons *cons; + struct ao_lisp_cons *args; + int f; + + DBG("func type "); DBG_POLY(func); DBG("\n"); + if (func == AO_LISP_NIL) + return ao_lisp_error(AO_LISP_INVALID, "func is nil"); + if (ao_lisp_poly_type(func) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "func is not list"); + cons = ao_lisp_poly_cons(func); + if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); + f = 0; + while (args) { + if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { + return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); + } + args = ao_lisp_poly_cons(args->cdr); + f++; + } + return ao_lisp_arg(cons, 0); +} + +static int +ao_lisp_cons_length(struct ao_lisp_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_lisp_poly_cons(cons->cdr); + } + return len; +} + +static ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons) +{ + ao_poly type; + struct ao_lisp_cons *lambda; + struct ao_lisp_cons *args; + int args_wanted; + int args_provided; + + lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + DBG("lambda "); DBG_CONS(lambda); DBG("\n"); + type = ao_lisp_arg(lambda, 0); + args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); + + args_wanted = ao_lisp_cons_length(args); + + /* Create a frame to hold the variables + */ + if (type == _ao_lisp_atom_lambda) + args_provided = ao_lisp_cons_length(cons) - 1; + else + args_provided = 1; + if (args_wanted != args_provided) + return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); + next_frame = ao_lisp_frame_new(args_wanted, 0); + DBG("new frame %d\n", OFFSET(next_frame)); + switch (type) { + case _ao_lisp_atom_lambda: { + int f; + struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); + + for (f = 0; f < args_wanted; f++) { + next_frame->vals[f].atom = args->car; + next_frame->vals[f].val = vals->car; + args = ao_lisp_poly_cons(args->cdr); + vals = ao_lisp_poly_cons(vals->cdr); + } + break; + } + case _ao_lisp_atom_lexpr: + case _ao_lisp_atom_nlambda: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = cons->cdr; + break; + case _ao_lisp_atom_macro: + next_frame->vals[0].atom = args->car; + next_frame->vals[0].val = ao_lisp_cons_poly(cons); + break; + } + return ao_lisp_arg(lambda, 2); +} + ao_poly ao_lisp_eval(ao_poly v) { @@ -48,7 +254,7 @@ ao_lisp_eval(ao_poly v) if (!been_here) { been_here = 1; - ao_lisp_root_add(&ao_lisp_cons_type, &stack); + ao_lisp_root_add(&ao_lisp_stack_type, &stack); ao_lisp_root_add(&ao_lisp_cons_type, &actuals); ao_lisp_root_add(&ao_lisp_cons_type, &formals); ao_lisp_root_add(&ao_lisp_cons_type, &formals_tail); @@ -57,29 +263,43 @@ ao_lisp_eval(ao_poly v) actuals = 0; formals = 0; formals_tail = 0; + cond = 0; for (;;) { restart: + if (cond) { + if (cond->car == AO_LISP_NIL) { + cond = AO_LISP_NIL; + v = AO_LISP_NIL; + } else { + if (ao_lisp_poly_type(cond->car) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "malformed cond"); + goto bail; + } + v = ao_lisp_poly_cons(cond->car)->car; + } + } + /* Build stack frames for each list */ while (ao_lisp_poly_type(v) == AO_LISP_CONS) { if (v == AO_LISP_NIL) break; - /* Push existing frame on the stack */ - if (cons++) { - struct ao_lisp_cons *frame; + /* Push existing bits on the stack */ + if (cons++) + if (!ao_lisp_stack_push()) + goto bail; - frame = ao_lisp_cons_cons(ao_lisp_cons_poly(actuals), formals); - stack = ao_lisp_cons_cons(ao_lisp_cons_poly(frame), stack); - } actuals = ao_lisp_poly_cons(v); formals = NULL; formals_tail = NULL; + cond = NULL; + v = actuals->car; - DBG("start: stack"); DBG_CONS(stack); DBG("\n"); - DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("start: formals"); DBG_CONS(formals); DBG("\n"); +// DBG("start: stack"); DBG_CONS(stack); DBG("\n"); +// DBG("start: actuals"); DBG_CONS(actuals); DBG("\n"); +// DBG("start: formals"); DBG_CONS(formals); DBG("\n"); } /* Evaluate primitive types */ @@ -95,19 +315,19 @@ ao_lisp_eval(ao_poly v) break; } - if (!cons) - break; - - for (;;) { + while (cons) { DBG("add formal: "); DBG_POLY(v); DBG("\n"); + /* We've processed the first element of the list, go check + * what kind of function we've got + */ if (formals == NULL) { if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); switch (b->args) { case AO_LISP_NLAMBDA: - v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); - goto done_eval; + formals = actuals; + goto eval; case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); @@ -115,15 +335,28 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG("\n"); if (ao_lisp_poly_type(v) != AO_LISP_CONS) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; + ao_lisp_error(AO_LISP_INVALID, "macro didn't return list"); + goto bail; } - /* Reset frame to the new list */ actuals = ao_lisp_poly_cons(v); v = actuals->car; goto restart; } + } else { + switch (func_type(v)) { + case _ao_lisp_atom_lambda: + case _ao_lisp_atom_lexpr: + break; + case _ao_lisp_atom_nlambda: + formals = actuals; + goto eval; + case _ao_lisp_atom_macro: + break; + default: + ao_lisp_error(AO_LISP_INVALID, "operator is not a function"); + goto bail; + } } } @@ -150,6 +383,8 @@ ao_lisp_eval(ao_poly v) v = formals->car; + eval: + /* Evaluate the resulting list */ if (ao_lisp_poly_type(v) == AO_LISP_BUILTIN) { struct ao_lisp_builtin *b = ao_lisp_poly_builtin(v); @@ -161,41 +396,54 @@ ao_lisp_eval(ao_poly v) DBG(" -> "); DBG_POLY(v); DBG ("\n"); + if (ao_lisp_exception) + goto bail; + + if (cond) + goto restart; } else { - ao_lisp_exception |= AO_LISP_INVALID; + v = ao_lisp_lambda(formals); + if (ao_lisp_exception) + goto bail; } - if (ao_lisp_exception) - return AO_LISP_NIL; - done_eval: - if (--cons) { - struct ao_lisp_cons *frame; - - /* Pop the previous frame off the stack */ - frame = ao_lisp_poly_cons(stack->car); - actuals = ao_lisp_poly_cons(frame->car); - formals = ao_lisp_poly_cons(frame->cdr); - formals_tail = NULL; - - /* Recompute the tail of the formals list */ - if (formals) { - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; - } - stack = ao_lisp_poly_cons(stack->cdr); - DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); - DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); - DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); + --cons; + if (cons) { + ao_lisp_stack_pop(); +// DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); +// DBG("stack pop: actuals"); DBG_CONS(actuals); DBG("\n"); +// DBG("stack pop: formals"); DBG_CONS(formals); DBG("\n"); } else { actuals = 0; formals = 0; formals_tail = 0; - DBG("done func\n"); - break; + ao_lisp_frame_current = 0; + } + if (next_frame) { + ao_lisp_frame_current = next_frame; + DBG("next frame %d\n", OFFSET(next_frame)); + next_frame = 0; + goto restart; + } + if (cond) { + if (v) { + v = ao_lisp_poly_cons(cond->car)->cdr; + if (v != AO_LISP_NIL) { + v = ao_lisp_poly_cons(v)->car; + goto restart; + } + } else { + cond = ao_lisp_poly_cons(cond->cdr); + goto restart; + } } } if (!cons) break; } + DBG("leaving frame at %d\n", OFFSET(ao_lisp_frame_current)); return v; +bail: + ao_lisp_stack_clear(); + return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 5aa50f6b..1853f6d7 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -95,7 +95,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; -static ao_poly * +ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { int f; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 6b603979..9c2ea74c 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -39,6 +39,7 @@ struct builtin_func funcs[] = { "quote", AO_LISP_NLAMBDA,builtin_quote, "set", AO_LISP_LEXPR, builtin_set, "setq", AO_LISP_MACRO, builtin_setq, + "cond", AO_LISP_NLAMBDA,builtin_cond, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -47,8 +48,25 @@ struct builtin_func funcs[] = { "%", AO_LISP_LEXPR, builtin_mod }; +ao_poly +ao_lisp_set_cond(struct ao_lisp_cons *c) +{ + (void) c; + return AO_LISP_NIL; +} + #define N_FUNC (sizeof funcs / sizeof funcs[0]) +/* Syntactic atoms */ +char *atoms[] = { + "lambda", + "nlambda", + "lexpr", + "macro" +}; + +#define N_ATOM (sizeof atoms / sizeof atoms[0]) + struct ao_lisp_frame *globals; static int @@ -65,9 +83,10 @@ is_atom(int offset) int main(int argc, char **argv) { - int f, o; + int f, o, i; ao_poly atom, val; struct ao_lisp_atom *a; + struct ao_lisp_builtin *b; int in_atom; printf("/*\n"); @@ -75,11 +94,15 @@ main(int argc, char **argv) ao_lisp_root_add(&ao_lisp_frame_type, &globals); globals = ao_lisp_frame_new(0, 0); for (f = 0; f < N_FUNC; f++) { - struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - struct ao_lisp_atom *a = ao_lisp_atom_intern(funcs[f].name); + b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + a = ao_lisp_atom_intern(funcs[f].name); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } + /* atoms for syntax */ + for (i = 0; i < N_ATOM; i++) + (void) ao_lisp_atom_intern(atoms[i]); + /* boolean constants */ a = ao_lisp_atom_intern("nil"); globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index a1f9fa1f..d780186a 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -25,12 +25,6 @@ ao_lisp_read_eval_print(void) // printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_OOM) - printf("out of memory\n"); - if (ao_lisp_exception & AO_LISP_DIVIDE_BY_ZERO) - printf("divide by zero\n"); - if (ao_lisp_exception & AO_LISP_INVALID) - printf("invalid operation\n"); ao_lisp_exception = 0; } else { ao_lisp_poly_print(out); diff --git a/src/nucleao-32/Makefile b/src/nucleao-32/Makefile index 1b7e0bb0..388e581c 100644 --- a/src/nucleao-32/Makefile +++ b/src/nucleao-32/Makefile @@ -46,6 +46,7 @@ ALTOS_SRC = \ ao_lisp_read.c \ ao_lisp_rep.c \ ao_lisp_frame.c \ + ao_lisp_error.c \ ao_exti_stm.c PRODUCT=Nucleo-32 diff --git a/src/nucleao-32/ao_pins.h b/src/nucleao-32/ao_pins.h index 76200176..65de89ed 100644 --- a/src/nucleao-32/ao_pins.h +++ b/src/nucleao-32/ao_pins.h @@ -24,6 +24,8 @@ #define LED_PIN_GREEN 3 #define AO_LED_GREEN (1 << LED_PIN_GREEN) #define AO_LED_PANIC AO_LED_GREEN +#define AO_CMD_LEN 128 +#define AO_LISP_POOL 2048 #define LEDS_AVAILABLE (AO_LED_GREEN) diff --git a/src/test/Makefile b/src/test/Makefile index bd195161..8d617eea 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -93,7 +93,8 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ - ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o + ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ + ao_lisp_error.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index e303869f..8bc677da 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -15,15 +15,18 @@ #include "ao_lisp.h" #include +#if 0 static struct ao_lisp_cons *list; static char *string; +#endif int main (int argc, char **argv) { +#if 0 int i, j; - struct ao_lisp_atom *atom; + struct ao_lisp_atom *atom; ao_lisp_root_add(&ao_lisp_cons_type, (void **) &list); ao_lisp_root_add(&ao_lisp_string_type, (void **) &string); @@ -47,7 +50,8 @@ main (int argc, char **argv) ao_lisp_poly_print(ao_lisp_atom_get(ao_lisp_atom_poly(atom))); printf("\n"); } -#if 1 +#endif +#if 0 list = ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_atom_poly(ao_lisp_atom_intern("+")), ao_lisp_cons_cons(ao_lisp_int_poly(3), @@ -58,7 +62,8 @@ main (int argc, char **argv) printf ("\n"); ao_lisp_poly_print(ao_lisp_eval(ao_lisp_cons_poly(list))); printf ("\n"); - +#endif +#if 1 ao_lisp_read_eval_print(); #endif } -- cgit v1.2.3 From 794718abc62f4610495fe2bd535a2b67bc46573c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 9 Nov 2016 09:14:50 -0800 Subject: altos/lisp: working on lexical scoping Not working yet Signed-off-by: Keith Packard --- src/lisp/Makefile | 4 +- src/lisp/ao_lisp.h | 147 ++++++++- src/lisp/ao_lisp_atom.c | 4 +- src/lisp/ao_lisp_builtin.c | 96 +++++- src/lisp/ao_lisp_const.lisp | 136 +++++++- src/lisp/ao_lisp_error.c | 81 +++++ src/lisp/ao_lisp_eval.c | 730 +++++++++++++++++++++--------------------- src/lisp/ao_lisp_frame.c | 21 ++ src/lisp/ao_lisp_make_const.c | 85 +++-- src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_prim.c | 10 +- src/test/Makefile | 2 +- 12 files changed, 876 insertions(+), 441 deletions(-) (limited to 'src/test/Makefile') diff --git a/src/lisp/Makefile b/src/lisp/Makefile index be19b432..f7edbe41 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -18,7 +18,9 @@ SRCS=\ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ - ao_lisp_error.c + ao_lisp_lambda.c \ + ao_lisp_eval.c \ + ao_lisp_error.c OBJS=$(SRCS:.c=.o) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 17f1e0f5..6a35d8ce 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -42,7 +42,9 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; #define _ao_lisp_atom_car _atom("car") #define _ao_lisp_atom_cdr _atom("cdr") #define _ao_lisp_atom_cons _atom("cons") +#define _ao_lisp_atom_last _atom("last") #define _ao_lisp_atom_cond _atom("cond") +#define _ao_lisp_atom_lambda _atom("lambda") #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -66,7 +68,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL]; #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 -#define AO_LISP_NUM_TYPE 7 +#define AO_LISP_LAMBDA 7 +#define AO_LISP_NUM_TYPE 8 #define AO_LISP_NIL 0 @@ -114,8 +117,8 @@ ao_lisp_poly(const void *addr, ao_poly type) { } struct ao_lisp_type { - void (*mark)(void *addr); int (*size)(void *addr); + void (*mark)(void *addr); void (*move)(void *addr); }; @@ -153,10 +156,47 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } -#define AO_LISP_LAMBDA 0 -#define AO_LISP_NLAMBDA 1 -#define AO_LISP_MACRO 2 -#define AO_LISP_LEXPR 3 +struct ao_lisp_stack { + ao_poly prev; + uint8_t state; + uint8_t macro; + ao_poly sexprs; + ao_poly values; + ao_poly values_tail; + ao_poly frame; + ao_poly macro_frame; + ao_poly list; +}; + +enum eval_state { + eval_sexpr, + eval_val, + eval_formal, + eval_exec, + eval_lambda_done, + eval_cond, + eval_cond_test +}; + +static inline struct ao_lisp_stack * +ao_lisp_poly_stack(ao_poly p) +{ + return ao_lisp_ref(p); +} + +static inline ao_poly +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 ao_poly ao_lisp_v; + +#define AO_LISP_FUNC_LAMBDA 0 +#define AO_LISP_FUNC_NLAMBDA 1 +#define AO_LISP_FUNC_MACRO 2 +#define AO_LISP_FUNC_LEXPR 3 struct ao_lisp_builtin { uint8_t type; @@ -165,9 +205,14 @@ struct ao_lisp_builtin { }; enum ao_lisp_builtin_id { + builtin_lambda, + builtin_lexpr, + builtin_nlambda, + builtin_macro, builtin_car, builtin_cdr, builtin_cons, + builtin_last, builtin_quote, builtin_set, builtin_setq, @@ -184,7 +229,7 @@ enum ao_lisp_builtin_id { builtin_greater, builtin_less_equal, builtin_greater_equal, - builtin_last + _builtin_last }; typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); @@ -197,6 +242,25 @@ ao_lisp_func(struct ao_lisp_builtin *b) return ao_lisp_builtins[b->func]; } +struct ao_lisp_lambda { + uint8_t type; + uint8_t args; + ao_poly code; + ao_poly frame; +}; + +static inline struct ao_lisp_lambda * +ao_lisp_poly_lambda(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) +{ + return ao_lisp_poly(lambda, AO_LISP_OTHER); +} + static inline void * ao_lisp_poly_other(ao_poly poly) { return ao_lisp_ref(poly); @@ -360,9 +424,9 @@ ao_lisp_string_patom(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; -extern struct ao_lisp_atom *ao_lisp_atoms; - -extern struct ao_lisp_frame *ao_lisp_frame_current; +extern struct ao_lisp_atom *ao_lisp_atoms; +extern struct ao_lisp_frame *ao_lisp_frame_global; +extern struct ao_lisp_frame *ao_lisp_frame_current; void ao_lisp_atom_print(ao_poly a); @@ -420,6 +484,9 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, ao_poly ao_lisp_arg(struct ao_lisp_cons *cons, int argc); +char * +ao_lisp_args_name(uint8_t args); + /* read */ ao_poly ao_lisp_read(void); @@ -440,9 +507,69 @@ ao_lisp_frame_new(int num); struct ao_lisp_frame * ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); +void +ao_lisp_frame_print(ao_poly p); + +/* lambda */ +extern const struct ao_lisp_type ao_lisp_lambda_type; + +struct ao_lisp_lambda * +ao_lisp_lambda_new(ao_poly cons); + +void +ao_lisp_lambda_print(ao_poly lambda); + +ao_poly +ao_lisp_lambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lexpr(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_nlambda(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_macro(struct ao_lisp_cons *cons); + +ao_poly +ao_lisp_lambda_eval(struct ao_lisp_lambda *lambda, + struct ao_lisp_cons *cons); + /* error */ +void +ao_lisp_stack_print(void); + ao_poly ao_lisp_error(int error, char *format, ...); +/* debugging macros */ + +#if DBG_EVAL +#define DBG_CODE 1 +int ao_lisp_stack_depth; +#define DBG_DO(a) a +#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) +#define DBG_IN() (++ao_lisp_stack_depth) +#define DBG_OUT() (--ao_lisp_stack_depth) +#define DBG_RESET() (ao_lisp_stack_depth = 0) +#define DBG(...) printf(__VA_ARGS__) +#define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#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() +#else +#define DBG_DO(a) +#define DBG_INDENT() +#define DBG_IN() +#define DBG_OUT() +#define DBG(...) +#define DBGI(...) +#define DBG_CONS(a) +#define DBG_POLY(a) +#define DBG_RESET() +#define DBG_STACK() +#endif + #endif /* _AO_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 41ba97f5..d7cb1996 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -89,8 +89,8 @@ ao_lisp_atom_intern(char *name) return atom; } -static struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; static void ao_lisp_atom_init(void) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 49b6c37d..c38ba165 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -39,11 +39,71 @@ const struct ao_lisp_type ao_lisp_builtin_type = { .move = builtin_move }; +#ifdef AO_LISP_MAKE_CONST +char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + return "???"; +} +char *ao_lisp_args_name(uint8_t args) { + return "???"; +} +#else +static const ao_poly builtin_names[] = { + [builtin_lambda] = _ao_lisp_atom_lambda, + [builtin_lexpr] = _ao_lisp_atom_lexpr, + [builtin_nlambda] = _ao_lisp_atom_nlambda, + [builtin_macro] = _ao_lisp_atom_macro, + [builtin_car] = _ao_lisp_atom_car, + [builtin_cdr] = _ao_lisp_atom_cdr, + [builtin_cons] = _ao_lisp_atom_cons, + [builtin_last] = _ao_lisp_atom_last, + [builtin_quote] = _ao_lisp_atom_quote, + [builtin_set] = _ao_lisp_atom_set, + [builtin_setq] = _ao_lisp_atom_setq, + [builtin_cond] = _ao_lisp_atom_cond, + [builtin_print] = _ao_lisp_atom_print, + [builtin_patom] = _ao_lisp_atom_patom, + [builtin_plus] = _ao_lisp_atom_2b, + [builtin_minus] = _ao_lisp_atom_2d, + [builtin_times] = _ao_lisp_atom_2a, + [builtin_divide] = _ao_lisp_atom_2f, + [builtin_mod] = _ao_lisp_atom_25, + [builtin_equal] = _ao_lisp_atom_3d, + [builtin_less] = _ao_lisp_atom_3c, + [builtin_greater] = _ao_lisp_atom_3e, + [builtin_less_equal] = _ao_lisp_atom_3c3d, + [builtin_greater_equal] = _ao_lisp_atom_3e3d, +}; + +static char * +ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { + if (0 <= b && b < _builtin_last) + return ao_lisp_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_lisp_args_atoms[] = { + [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, + [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, + [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, + [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, +}; + +char * +ao_lisp_args_name(uint8_t args) +{ + if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) + return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; + return "(unknown)"; +} +#endif + void ao_lisp_builtin_print(ao_poly b) { - (void) b; - printf("[builtin]"); + 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)); } ao_poly @@ -116,6 +176,24 @@ ao_lisp_cons(struct ao_lisp_cons *cons) return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); } +ao_poly +ao_lisp_last(struct ao_lisp_cons *cons) +{ + ao_poly l; + if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) + return AO_LISP_NIL; + l = ao_lisp_arg(cons, 0); + while (l) { + struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + if (!list->cdr) + return list->car; + l = list->cdr; + } + return AO_LISP_NIL; +} + ao_poly ao_lisp_quote(struct ao_lisp_cons *cons) { @@ -151,15 +229,6 @@ ao_lisp_setq(struct ao_lisp_cons *cons) ao_poly ao_lisp_cond(struct ao_lisp_cons *cons) { - int argc; - struct ao_lisp_cons *arg; - - argc = 0; - for (arg = cons, argc = 0; arg; arg = ao_lisp_poly_cons(arg->cdr), argc++) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", - ao_lisp_poly_atom(_ao_lisp_atom_cond)->name, argc); - } ao_lisp_set_cond(cons); return AO_LISP_NIL; } @@ -380,9 +449,14 @@ ao_lisp_greater_equal(struct ao_lisp_cons *cons) } ao_lisp_func_t ao_lisp_builtins[] = { + [builtin_lambda] = ao_lisp_lambda, + [builtin_lexpr] = ao_lisp_lexpr, + [builtin_nlambda] = ao_lisp_nlambda, + [builtin_macro] = ao_lisp_macro, [builtin_car] = ao_lisp_car, [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, + [builtin_last] = ao_lisp_last, [builtin_quote] = ao_lisp_quote, [builtin_set] = ao_lisp_set, [builtin_setq] = ao_lisp_setq, diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5ca89bd4..621fefc4 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -1,7 +1,129 @@ -cadr (lambda (l) (car (cdr l))) -caddr (lambda (l) (car (cdr (cdr l)))) -list (lexpr (l) l) -1+ (lambda (x) (+ x 1)) -1- (lambda (x) (- x 1)) -last (lambda (x) (cond ((cdr x) (last (cdr x))) ((car x)))) -prog* (lexpr (l) (last l)) + ; basic list accessors + + +(setq cadr (lambda (l) (car (cdr l)))) +(setq caddr (lambda (l) (car (cdr (cdr l))))) +(setq list (lexpr (l) l)) + + ; evaluate a list of sexprs + +(setq progn (lexpr (l) (last l))) + + ; simple math operators + +(setq 1+ (lambda (x) (+ x 1))) +(setq 1- (lambda (x) (- x 1))) + + ; define a variable without returning the value + +(set 'def (macro (def-param) + (list + 'progn + (list + 'set + (list + 'quote + (car def-param)) + (cadr def-param) + ) + (list + 'quote + (car def-param) + ) + ) + ) + ) + + ; define a set of local + ; variables and then evaluate + ; a list of sexprs + ; + ; (let (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let ((x 1) (y)) (setq y (+ x 1)) y) + +(def let (macro (let-param) + ((lambda (vars exprs make-names make-exprs make-nils) + (progn + + ; + ; make the list of names in the let + ; + + (set 'make-names (lambda (vars) + (cond (vars + (cons (car (car vars)) + (make-names (cdr vars)))) + ) + ) + ) + ; + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + ; + (set 'make-exprs (lambda (vars exprs) + (progn + (cond (vars (cons + (list set + (list quote + (car (car vars)) + ) + (cadr (car vars)) + ) + (make-exprs (cdr vars) exprs) + ) + ) + (exprs) + ) + ) + ) + ) + (set 'exprs (make-exprs vars exprs)) + + ; + ; the parameters to the lambda is a list + ; of nils of the right length + ; + (set 'make-nils (lambda (vars) + (cond (vars (cons nil (make-nils (cdr vars)))) + ) + ) + ) + ; + ; build the lambda. + ; + (set 'last-let-value + (cons + (list + 'lambda + (make-names vars) + (cond ((cdr exprs) (cons 'progn exprs)) + ((car exprs)) + ) + ) + (make-nils vars) + ) + ) + ) + + ) + (car let-param) + (cdr let-param) + () + () + () + ) + ) + ) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index ea8111d9..cedc107c 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -15,6 +15,86 @@ #include "ao_lisp.h" #include +static void +ao_lisp_error_cons(char *name, struct ao_lisp_cons *cons) +{ + int first = 1; + printf("\t\t%s(", name); + if (cons) { + while (cons) { + if (!first) + printf("\t\t "); + else + first = 0; + ao_lisp_poly_print(cons->car); + printf("\n"); + cons = ao_lisp_poly_cons(cons->cdr); + } + printf("\t\t )\n"); + } else + printf(")\n"); +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +static void +ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + 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"); + } + if (frame->next) + ao_lisp_error_frame(indent + 1, "next: ", ao_lisp_poly_frame(frame->next)); + } + tabs(indent); + printf(" }\n"); +} + +static const char *state_names[] = { + "sexpr", + "val", + "formal", + "exec", + "cond", + "cond_test", +}; + +void +ao_lisp_stack_print(void) +{ + struct ao_lisp_stack *s; + printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + ao_lisp_error_frame(0, "Frame: ", ao_lisp_frame_current); + 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_cons ("sexprs: ", ao_lisp_poly_cons(s->sexprs)); + ao_lisp_error_cons ("values: ", ao_lisp_poly_cons(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, ...) { @@ -25,5 +105,6 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); + ao_lisp_stack_print(); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index a5c74250..f4196219 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -12,60 +12,9 @@ * General Public License for more details. */ +#define DBG_EVAL 1 #include "ao_lisp.h" - -#if 0 -#define DBG_CODE 1 -static int stack_depth; -#define DBG_INDENT() do { int _s; for(_s = 0; _s < stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++stack_depth) -#define DBG_OUT() (--stack_depth) -#define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG_INDENT(); DBG("%4d: ", __LINE__); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_print(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#else -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#endif - -enum eval_state { - eval_sexpr, - eval_val, - eval_formal, - eval_exec, - eval_exec_direct, - eval_cond, - eval_cond_test -}; - -struct ao_lisp_stack { - ao_poly prev; - uint8_t state; - uint8_t macro; - ao_poly actuals; - ao_poly formals; - ao_poly formals_tail; - ao_poly frame; -}; - -static struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} +#include static int stack_size(void *addr) @@ -79,10 +28,11 @@ stack_mark(void *addr) { struct ao_lisp_stack *stack = addr; for (;;) { - ao_lisp_poly_mark(stack->actuals, 0); - ao_lisp_poly_mark(stack->formals, 0); - /* no need to mark formals_tail */ + 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->macro_frame, 0); stack = ao_lisp_poly_stack(stack->prev); if (ao_lisp_mark_memory(stack, sizeof (struct ao_lisp_stack))) break; @@ -91,29 +41,6 @@ stack_mark(void *addr) static const struct ao_lisp_type ao_lisp_stack_type; -#if DBG_CODE -static void -stack_validate_tail(struct ao_lisp_stack *stack) -{ - struct ao_lisp_cons *head = ao_lisp_poly_cons(stack->formals); - struct ao_lisp_cons *tail = ao_lisp_poly_cons(stack->formals_tail); - struct ao_lisp_cons *cons; - for (cons = head; cons && cons->cdr && cons != tail; cons = ao_lisp_poly_cons(cons->cdr)) - ; - if (cons != tail || (tail && tail->cdr)) { - if (!tail) { - printf("tail null\n"); - } else { - printf("tail validate fail head %d actual %d recorded %d\n", - OFFSET(head), OFFSET(cons), OFFSET(tail)); - abort(); - } - } -} -#else -#define stack_validate_tail(s) -#endif - static void stack_move(void *addr) { @@ -122,15 +49,15 @@ stack_move(void *addr) while (stack) { void *prev; int ret; - (void) ao_lisp_poly_move(&stack->actuals, 0); - (void) ao_lisp_poly_move(&stack->formals, 0); - (void) ao_lisp_poly_move(&stack->formals_tail, 0); + (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->macro_frame, 0); prev = ao_lisp_poly_stack(stack->prev); ret = ao_lisp_move(&ao_lisp_stack_type, &prev); if (prev != ao_lisp_poly_stack(stack->prev)) stack->prev = ao_lisp_stack_poly(prev); - stack_validate_tail(stack); if (ret) break; stack = ao_lisp_poly_stack(stack->prev); @@ -143,199 +70,421 @@ static const struct ao_lisp_type ao_lisp_stack_type = { .move = stack_move }; -static struct ao_lisp_stack *ao_lisp_stack; -static ao_poly ao_lisp_v; -static uint8_t been_here; - -#if DBG_CODE -static void -stack_validate_tails(void) -{ - struct ao_lisp_stack *stack; - - for (stack = ao_lisp_stack; stack; stack = ao_lisp_poly_stack(stack->prev)) - stack_validate_tail(stack); -} -#else -#define stack_validate_tails(s) -#endif +struct ao_lisp_stack *ao_lisp_stack; +ao_poly ao_lisp_v; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) { ao_lisp_stack->state = eval_cond; - ao_lisp_stack->actuals = ao_lisp_cons_poly(c); + ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); return AO_LISP_NIL; } -void +static void ao_lisp_stack_reset(struct ao_lisp_stack *stack) { stack->state = eval_sexpr; stack->macro = 0; - stack->actuals = AO_LISP_NIL; - stack->formals = AO_LISP_NIL; - stack->formals_tail = AO_LISP_NIL; - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack_validate_tails(); + stack->sexprs = AO_LISP_NIL; + stack->values = AO_LISP_NIL; + stack->values_tail = AO_LISP_NIL; } -int -ao_lisp_stack_push(void) +static void +ao_lisp_frames_dump(void) { - stack_validate_tails(); - if (ao_lisp_stack) { - DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); + struct ao_lisp_stack *s; + DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { + DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); + DBGI(".. macro frame: "); DBG_POLY(s->frame); DBG("\n"); } +} + +static int +ao_lisp_stack_push(void) +{ DBGI("stack push\n"); DBG_IN(); struct ao_lisp_stack *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); - stack_validate_tails(); + ao_lisp_frames_dump(); return 1; } -void +static void ao_lisp_stack_pop(void) { if (!ao_lisp_stack) return; - stack_validate_tails(); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); + ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); DBG_OUT(); DBGI("stack pop\n"); - ao_lisp_stack = ao_lisp_poly_stack(ao_lisp_stack->prev); - 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_stack) { - DBGI("formals "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - DBGI("actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - } + ao_lisp_frames_dump(); } static void ao_lisp_stack_clear(void) { - stack_validate_tails(); ao_lisp_stack = NULL; ao_lisp_frame_current = NULL; + ao_lisp_v = AO_LISP_NIL; } -static ao_poly +static int func_type(ao_poly func) { - struct ao_lisp_cons *cons; - struct ao_lisp_cons *args; - int f; - - DBGI("func type "); DBG_POLY(func); DBG("\n"); if (func == AO_LISP_NIL) return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - if (ao_lisp_poly_type(func) == AO_LISP_BUILTIN) { - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(func); - return b->args; - } else if (ao_lisp_poly_type(func) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(func); - if (!ao_lisp_check_argc(_ao_lisp_atom_lambda, cons, 3, 3)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, cons, 1, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - args = ao_lisp_poly_cons(ao_lisp_arg(cons, 1)); - f = 0; - while (args) { - if (ao_lisp_poly_type(args->car) != AO_LISP_ATOM) { - return ao_lisp_error(ao_lisp_arg(cons, 0), "formal %d is not an atom", f); - } - args = ao_lisp_poly_cons(args->cdr); - f++; - } - return ao_lisp_arg(cons, 0); - } else { + switch (ao_lisp_poly_type(func)) { + case AO_LISP_BUILTIN: + return ao_lisp_poly_builtin(func)->args; + case AO_LISP_LAMBDA: + return ao_lisp_poly_lambda(func)->args; + default: ao_lisp_error(AO_LISP_INVALID, "not a func"); - abort(); - return AO_LISP_NIL; + return -1; } } +/* + * Flattened eval to avoid stack issues + */ + +/* + * Evaluate an s-expression + * + * For a list, evaluate all of the elements and + * then execute the resulting function call. + * + * Each element of the list is evaluated in + * a clean stack context. + * + * The current stack state is set to 'formal' so that + * when the evaluation is complete, the value + * will get appended to the values list. + * + * For other types, compute the value directly. + */ + static int -ao_lisp_cons_length(struct ao_lisp_cons *cons) +ao_lisp_eval_sexpr(void) { - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); + DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_CONS: + if (ao_lisp_v == AO_LISP_NIL) { + if (!ao_lisp_stack->values) { + /* + * empty list evaluates to empty list + */ + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + /* + * done with arguments, go execute it + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + ao_lisp_stack->state = eval_exec; + } + } else { + if (!ao_lisp_stack->values) + ao_lisp_stack->list = ao_lisp_v; + /* + * Evaluate another argument and then switch + * to 'formal' to add the value to the values + * list + */ + ao_lisp_stack->sexprs = ao_lisp_v; + ao_lisp_stack->state = eval_formal; + if (!ao_lisp_stack_push()) + return 0; + /* + * push will reset the state to 'sexpr', which + * will evaluate the expression + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + } + break; + case AO_LISP_ATOM: + DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); + /* fall through */ + case AO_LISP_INT: + case AO_LISP_STRING: + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_val; + break; } - return len; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; } -static ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) +/* + * A value has been computed. + * + * If the value was computed from a macro, + * then we want to reset the current context + * to evaluate the macro result again. + * + * If not a macro, then pop the stack. + * If the stack is empty, we're done. + * Otherwise, the stack will contain + * the next state. + */ + +static int +ao_lisp_eval_val(void) { - ao_poly type; - struct ao_lisp_cons *lambda; - struct ao_lisp_cons *args; - struct ao_lisp_frame *next_frame; - int args_wanted; - int args_provided; + DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); + if (ao_lisp_stack->macro) { + DBGI("..macro %d\n", ao_lisp_stack->macro); + DBGI("..current frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI("..saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + DBGI("..macro frame "); DBG_POLY(ao_lisp_stack->macro_frame); DBG("\n"); + DBGI("..sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("..values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + /* + * Re-use the current stack to evaluate + * the value from the macro + */ + ao_lisp_stack->state = eval_sexpr; +// assert(ao_lisp_stack->frame == ao_lisp_stack->macro_frame); + ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->macro_frame); + ao_lisp_stack->frame = ao_lisp_stack->macro_frame; + ao_lisp_stack->macro = 0; + ao_lisp_stack->macro_frame = AO_LISP_NIL; + ao_lisp_stack->sexprs = AO_LISP_NIL; + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + } else { + /* + * Value computed, pop the stack + * to figure out what to do with the value + */ + ao_lisp_stack_pop(); + } + DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_stack->state : -1); + return 1; +} - lambda = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - DBGI("lambda "); DBG_CONS(lambda); DBG("\n"); - type = ao_lisp_arg(lambda, 0); - args = ao_lisp_poly_cons(ao_lisp_arg(lambda, 1)); +/* + * A formal has been computed. + * + * If this is the first formal, then + * check to see if we've got a lamda/lexpr or + * macro/nlambda. + * + * For lambda/lexpr, go compute another formal. + * This will terminate when the sexpr state + * sees nil. + * + * For macro/nlambda, we're done, so move the + * sexprs into the values and go execute it. + */ - args_wanted = ao_lisp_cons_length(args); +static int +ao_lisp_eval_formal(void) +{ + ao_poly formal; - /* Create a frame to hold the variables - */ - if (type == _ao_lisp_atom_lambda) - args_provided = ao_lisp_cons_length(cons) - 1; - else - args_provided = 1; - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, not %d", args_wanted, args_provided); - next_frame = ao_lisp_frame_new(args_wanted); -// DBGI("new frame %d\n", OFFSET(next_frame)); - switch (type) { - case _ao_lisp_atom_lambda: { - int f; - struct ao_lisp_cons *vals = ao_lisp_poly_cons(cons->cdr); - - for (f = 0; f < args_wanted; f++) { - next_frame->vals[f].atom = args->car; - next_frame->vals[f].val = vals->car; - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); + DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); + + /* Check what kind of function we've got */ + if (!ao_lisp_stack->values) { + switch (func_type(ao_lisp_v)) { + case AO_LISP_FUNC_LAMBDA: + case AO_LISP_FUNC_LEXPR: + DBGI(".. lambda or lexpr\n"); + break; + case AO_LISP_FUNC_MACRO: + ao_lisp_stack->macro = 1; + DBGI(".. macro %d\n", ao_lisp_stack->macro); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + ao_lisp_stack->macro_frame = ao_lisp_stack->frame; + /* fall through ... */ + case AO_LISP_FUNC_NLAMBDA: + DBGI(".. nlambda or macro\n"); + ao_lisp_stack->values = ao_lisp_stack->sexprs; + ao_lisp_stack->values_tail = AO_LISP_NIL; + ao_lisp_stack->state = eval_exec; + return 1; + case -1: + return 0; } - break; } - case _ao_lisp_atom_lexpr: - case _ao_lisp_atom_nlambda: - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = cons->cdr; + + /* Append formal to list of values */ + formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + if (!formal) + return 0; + + if (ao_lisp_stack->values_tail) + ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; + else + ao_lisp_stack->values = formal; + ao_lisp_stack->values_tail = formal; + + DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + + /* + * Step to the next argument, if this is last, then + * 'sexpr' will end up switching to 'exec' + */ + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + + ao_lisp_stack->state = eval_sexpr; + + DBGI(".. "); DBG_POLY(ao_lisp_v); DBG("\n"); + return 1; +} + +/* + * Start executing a function call + * + * Most builtins are easy, just call the function. + * 'cond' is magic; it sticks the list of clauses + * in 'sexprs' and switches to 'cond' state. That + * bit of magic is done in ao_lisp_set_cond. + * + * Lambdas build a new frame to hold the locals and + * then re-use the current stack context to evaluate + * the s-expression from the lambda. + */ + +static int +ao_lisp_eval_exec(void) +{ + ao_poly v; + DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->sexprs = AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_v)) { + case AO_LISP_BUILTIN: + ao_lisp_stack->state = eval_val; + v = ao_lisp_func(ao_lisp_poly_builtin(ao_lisp_v)) ( + ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); + DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_poly atom = ao_lisp_arg(cons, 1); + ao_poly val = ao_lisp_arg(cons, 2); + DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); + }); + ao_lisp_v = v; + DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; - case _ao_lisp_atom_macro: - next_frame->vals[0].atom = args->car; - next_frame->vals[0].val = ao_lisp_cons_poly(cons); + case AO_LISP_LAMBDA: + ao_lisp_stack->state = eval_sexpr; + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + ao_lisp_v = ao_lisp_lambda_eval(ao_lisp_poly_lambda(ao_lisp_v), + ao_lisp_poly_cons(ao_lisp_stack->values)); + DBGI(".. sexpr "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } - next_frame->next = ao_lisp_frame_poly(ao_lisp_frame_current); - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(next_frame); - return ao_lisp_arg(lambda, 2); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_stack->values_tail = AO_LISP_NIL; + return 1; } +static int +ao_lisp_eval_lambda_done(void) +{ + DBGI("lambda_done: "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBG_STACK(); + return 1; +} + +/* + * Start evaluating the next cond clause + * + * If the list of clauses is empty, then + * the result of the cond is nil. + * + * Otherwise, set the current stack state to 'cond_test' and create a + * new stack context to evaluate the test s-expression. Once that's + * complete, we'll land in 'cond_test' to finish the clause. + */ +static int +ao_lisp_eval_cond(void) +{ + DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (!ao_lisp_stack->sexprs) { + ao_lisp_v = AO_LISP_NIL; + ao_lisp_stack->state = eval_val; + } else { + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; + if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { + ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); + return 0; + } + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + ao_lisp_stack->state = eval_cond_test; + if (!ao_lisp_stack_push()) + return 0; + ao_lisp_stack->state = eval_sexpr; + } + return 1; +} + +/* + * Finish a cond clause. + * + * Check the value from the test expression, if + * non-nil, then set up to evaluate the value expression. + * + * Otherwise, step to the next clause and go back to the 'cond' + * state + */ +static int +ao_lisp_eval_cond_test(void) +{ + DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); + DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); + if (ao_lisp_v) { + struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); + struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); + + ao_lisp_stack->state = eval_val; + if (c) { + ao_lisp_v = c->car; + if (!ao_lisp_stack_push()) + return 0; + } + } else { + ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; + DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + ao_lisp_stack->state = eval_cond; + } + return 1; +} + +static int (*const evals[])(void) = { + [eval_sexpr] = ao_lisp_eval_sexpr, + [eval_val] = ao_lisp_eval_val, + [eval_formal] = ao_lisp_eval_formal, + [eval_exec] = ao_lisp_eval_exec, + [eval_cond] = ao_lisp_eval_cond, + [eval_cond_test] = ao_lisp_eval_cond_test, +}; + ao_poly ao_lisp_eval(ao_poly _v) { - ao_poly formal; + static uint8_t been_here; ao_lisp_v = _v; if (!been_here) { @@ -345,165 +494,16 @@ ao_lisp_eval(ao_poly _v) } if (!ao_lisp_stack_push()) - goto bail; - - for (;;) { - if (ao_lisp_exception) - goto bail; - switch (ao_lisp_stack->state) { - case eval_sexpr: - DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_CONS: - if (ao_lisp_v == AO_LISP_NIL) { - ao_lisp_stack->state = eval_exec; - break; - } - ao_lisp_stack->actuals = ao_lisp_v; - DBGI("actuals now "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - goto bail; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - stack_validate_tails(); - break; - case AO_LISP_ATOM: - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_INT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - break; - } - break; - case eval_val: - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_stack_pop(); - if (!ao_lisp_stack) - return ao_lisp_v; - DBGI("..state %d\n", ao_lisp_stack->state); - break; - - case eval_formal: - /* Check what kind of function we've got */ - if (!ao_lisp_stack->formals) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_LAMBDA: - case _ao_lisp_atom_lambda: - case AO_LISP_LEXPR: - case _ao_lisp_atom_lexpr: - DBGI(".. lambda or lexpr\n"); - break; - case AO_LISP_MACRO: - case _ao_lisp_atom_macro: - ao_lisp_stack->macro = 1; - case AO_LISP_NLAMBDA: - case _ao_lisp_atom_nlambda: - DBGI(".. nlambda or macro\n"); - ao_lisp_stack->formals = ao_lisp_stack->actuals; - ao_lisp_stack->formals_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec_direct; - stack_validate_tails(); - break; - } - if (ao_lisp_stack->state == eval_exec_direct) - break; - } - - DBGI("add formal "); DBG_POLY(ao_lisp_v); DBG("\n"); - stack_validate_tails(); - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); - stack_validate_tails(); - if (!formal) - goto bail; - - if (ao_lisp_stack->formals_tail) - ao_lisp_poly_cons(ao_lisp_stack->formals_tail)->cdr = formal; - else - ao_lisp_stack->formals = formal; - ao_lisp_stack->formals_tail = formal; - - DBGI("formals now "); DBG_POLY(ao_lisp_stack->formals); DBG("\n"); - - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - - stack_validate_tails(); - ao_lisp_stack->state = eval_sexpr; + return AO_LISP_NIL; - break; - case eval_exec: - if (!ao_lisp_stack->formals) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - break; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->formals)->car; - case eval_exec_direct: - DBGI("exec: macro %d ", ao_lisp_stack->macro); DBG_POLY(ao_lisp_v); DBG(" formals "); DBG_POLY(ao_lisp_stack->formals); DBG ("\n"); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_BUILTIN) { - stack_validate_tails(); - struct ao_lisp_builtin *b = ao_lisp_poly_builtin(ao_lisp_v); - stack_validate_tails(); - struct ao_lisp_cons *f = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->formals)->cdr); - - DBGI(".. builtin formals "); DBG_CONS(f); DBG("\n"); - stack_validate_tails(); - if (ao_lisp_stack->macro) - ao_lisp_stack->state = eval_sexpr; - else - ao_lisp_stack->state = eval_val; - ao_lisp_stack->macro = 0; - ao_lisp_stack->actuals = ao_lisp_stack->formals = ao_lisp_stack->formals_tail = AO_LISP_NIL; - ao_lisp_v = ao_lisp_func(b) (f); - DBGI("builtin result:"); DBG_POLY(ao_lisp_v); DBG ("\n"); - if (ao_lisp_exception) - goto bail; - break; - } else { - ao_lisp_v = ao_lisp_lambda(ao_lisp_poly_cons(ao_lisp_stack->formals)); - ao_lisp_stack_reset(ao_lisp_stack); - } - break; - case eval_cond: - DBGI("cond: "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - if (!ao_lisp_stack->actuals) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->actuals)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - goto bail; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - ao_lisp_stack->state = eval_cond_test; - stack_validate_tails(); - ao_lisp_stack_push(); - stack_validate_tails(); - ao_lisp_stack->state = eval_sexpr; - } - break; - case eval_cond_test: - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" actuals "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - if (ao_lisp_v) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->actuals)->car); - struct ao_lisp_cons *c = ao_lisp_poly_cons(car->cdr); - if (c) { - ao_lisp_v = c->car; - ao_lisp_stack->state = eval_sexpr; - } else { - ao_lisp_stack->state = eval_val; - } - } else { - ao_lisp_stack->actuals = ao_lisp_poly_cons(ao_lisp_stack->actuals)->cdr; - DBGI("actuals now "); DBG_POLY(ao_lisp_stack->actuals); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - break; + while (ao_lisp_stack) { +// DBG_STACK(); + if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { + ao_lisp_stack_clear(); + return AO_LISP_NIL; } } -bail: - ao_lisp_stack_clear(); - return AO_LISP_NIL; + DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); + ao_lisp_frame_current = NULL; + return ao_lisp_v; } diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 8791c4de..7978f20a 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -100,6 +100,27 @@ const struct ao_lisp_type ao_lisp_frame_type = { .move = frame_move }; +void +ao_lisp_frame_print(ao_poly p) +{ + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + int f; + + printf ("{"); + if (frame) { + 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->next) + ao_lisp_poly_print(frame->next); + } + printf("}"); +} + ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f2e3cea1..501052b9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -33,34 +33,32 @@ struct builtin_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, - "set", AO_LISP_LEXPR, builtin_set, - "setq", AO_LISP_MACRO, builtin_setq, - "cond", AO_LISP_NLAMBDA,builtin_cond, - "print", AO_LISP_LEXPR, builtin_print, - "patom", AO_LISP_LEXPR, builtin_patom, - "+", 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, - "=", AO_LISP_LEXPR, builtin_equal, - "<", AO_LISP_LEXPR, builtin_less, - ">", AO_LISP_LEXPR, builtin_greater, - "<=", AO_LISP_LEXPR, builtin_less_equal, - ">=", AO_LISP_LEXPR, builtin_greater_equal, + "lambda", AO_LISP_FUNC_NLAMBDA, builtin_lambda, + "lexpr", AO_LISP_FUNC_NLAMBDA, builtin_lexpr, + "nlambda", AO_LISP_FUNC_NLAMBDA, builtin_nlambda, + "macro", AO_LISP_FUNC_NLAMBDA, builtin_macro, + "car", AO_LISP_FUNC_LAMBDA, builtin_car, + "cdr", AO_LISP_FUNC_LAMBDA, builtin_cdr, + "cons", AO_LISP_FUNC_LAMBDA, builtin_cons, + "last", AO_LISP_FUNC_LAMBDA, builtin_last, + "quote", AO_LISP_FUNC_NLAMBDA, builtin_quote, + "set", AO_LISP_FUNC_LAMBDA, builtin_set, + "setq", AO_LISP_FUNC_MACRO, builtin_setq, + "cond", AO_LISP_FUNC_NLAMBDA, builtin_cond, + "print", AO_LISP_FUNC_LEXPR, builtin_print, + "patom", AO_LISP_FUNC_LEXPR, builtin_patom, + "+", AO_LISP_FUNC_LEXPR, builtin_plus, + "-", AO_LISP_FUNC_LEXPR, builtin_minus, + "*", AO_LISP_FUNC_LEXPR, builtin_times, + "/", AO_LISP_FUNC_LEXPR, builtin_divide, + "%", AO_LISP_FUNC_LEXPR, builtin_mod, + "=", AO_LISP_FUNC_LEXPR, builtin_equal, + "<", AO_LISP_FUNC_LEXPR, builtin_less, + ">", AO_LISP_FUNC_LEXPR, builtin_greater, + "<=", AO_LISP_FUNC_LEXPR, builtin_less_equal, + ">=", AO_LISP_FUNC_LEXPR, builtin_greater_equal, }; -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - (void) c; - return AO_LISP_NIL; -} - #define N_FUNC (sizeof funcs / sizeof funcs[0]) /* Syntactic atoms */ @@ -90,19 +88,18 @@ int main(int argc, char **argv) { int f, o, i; - ao_poly atom, val; + ao_poly sexpr, val; struct ao_lisp_atom *a; struct ao_lisp_builtin *b; int in_atom; printf("/*\n"); printf(" * Generated file, do not edit\n"); - ao_lisp_root_add(&ao_lisp_frame_type, &globals); - globals = ao_lisp_frame_new(0); for (f = 0; f < N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_builtin_poly(b)); } /* atoms for syntax */ @@ -110,23 +107,25 @@ main(int argc, char **argv) (void) ao_lisp_atom_intern(atoms[i]); /* boolean constants */ - a = ao_lisp_atom_intern("nil"); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), AO_LISP_NIL); + ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), + AO_LISP_NIL); a = ao_lisp_atom_intern("t"); - globals = ao_lisp_frame_add(globals, ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_poly(a)); for (;;) { - atom = ao_lisp_read(); - if (!atom) + sexpr = ao_lisp_read(); + if (!sexpr) 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"); + printf ("sexpr: "); + ao_lisp_poly_print(sexpr); + printf("\n"); + val = ao_lisp_eval(sexpr); + if (ao_lisp_exception) exit(1); - } - globals = ao_lisp_frame_add(globals, atom, val); + printf("\t"); + ao_lisp_poly_print(val); + printf("\n"); } /* Reduce to referenced values */ @@ -136,7 +135,7 @@ main(int argc, char **argv) printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(globals)); + printf("#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index c11ec25d..476843d8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -262,6 +262,7 @@ static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, }; diff --git a/src/lisp/ao_lisp_prim.c b/src/lisp/ao_lisp_prim.c index 3c081ee8..bfd75ae3 100644 --- a/src/lisp/ao_lisp_prim.c +++ b/src/lisp/ao_lisp_prim.c @@ -45,7 +45,15 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { [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 * diff --git a/src/test/Makefile b/src/test/Makefile index 8d617eea..7395e832 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -94,7 +94,7 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_prim.o ao_lisp_eval.o ao_lisp_poly.o \ ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ - ao_lisp_error.o + ao_lisp_lambda.o ao_lisp_error.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -- 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/test/Makefile') 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 8f2d60b4c029bffaa559bd1f31f5b15230dfa674 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 11 Nov 2016 21:18:50 -0800 Subject: altos/lisp: Add save/restore to ao_lisp_test Allow testing of the save/restore code under Linux. Signed-off-by: Keith Packard --- src/test/Makefile | 4 ++-- src/test/ao_lisp_os.h | 3 +++ src/test/ao_lisp_test.c | 33 +++++++++++++++++++++++++++++++++ src/test/hanoi.lisp | 2 -- 4 files changed, 38 insertions(+), 4 deletions(-) (limited to 'src/test/Makefile') diff --git a/src/test/Makefile b/src/test/Makefile index d6777090..df24c2b6 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -91,9 +91,9 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_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 + ao_lisp_lambda.o ao_lisp_error.o ao_lisp_save.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h +$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h ao_lisp_os.h diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index c979697e..8b9c1475 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -22,6 +22,9 @@ #include #include +#define AO_LISP_POOL_TOTAL 3072 +#define AO_LISP_SAVE + extern int ao_lisp_getc(void); static inline void diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c index 69739100..41dae07a 100644 --- a/src/test/ao_lisp_test.c +++ b/src/test/ao_lisp_test.c @@ -18,6 +18,39 @@ static FILE *ao_lisp_file; static int newline = 1; +static char save_file[] = "lisp.image"; + +int +ao_lisp_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_lisp_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_LISP_POOL_TOTAL) + return 0; + return 1; +} + int ao_lisp_getc(void) { diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index 09a3611c..01398d91 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -125,5 +125,3 @@ (clear) (_hanoi len 0 1 2) ) - -(hanoi) -- cgit v1.2.3 From 9f19cb10cd12f86b12d0599bab5c2ee351d814ae Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 16 Nov 2016 13:59:54 -0800 Subject: altos/test: Disable position independent executables This makes debugging programs so much harder --- src/test/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/test/Makefile') diff --git a/src/test/Makefile b/src/test/Makefile index df24c2b6..fae46ac8 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 -DAO_LISP_TEST +CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp -O3 -g -Wall -DAO_LISP_TEST -no-pie all: $(PROGS) ao_aprs_data.wav -- 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/test/Makefile') 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 8f833f31f625526a5f1e9a1bd561733b5bb2bcaa Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 18 Nov 2016 21:17:54 -0800 Subject: altos/lisp: Build new ao_lisp_stack.c into test and lambdakey Helpful to include the new source file. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 1 + src/test/Makefile | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) (limited to 'src/test/Makefile') diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index a4d78736..2609bea3 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -50,6 +50,7 @@ ALTOS_SRC = \ ao_lisp_error.c \ ao_lisp_lambda.c \ ao_lisp_save.c \ + ao_lisp_stack.c \ ao_lisp_os_save.c PRODUCT=LambdaKey-v1.0 diff --git a/src/test/Makefile b/src/test/Makefile index 0eaa9421..a22abe46 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -91,7 +91,7 @@ ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ ao_lisp_atom.o ao_lisp_int.o ao_lisp_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 ao_lisp_save.o + ao_lisp_lambda.o ao_lisp_error.o ao_lisp_save.o ao_lisp_stack.o ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -- cgit v1.2.3