From 9e1a787f8828fb7b750ad3310c89a89536ea5286 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 2 Nov 2016 14:18:54 -0700 Subject: [PATCH] altos/lisp: add set/setq and ' in reader Along with other small fixes Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 8 +++ src/lisp/ao_lisp_builtin.c | 76 +++++++++++++++++++++--- src/lisp/ao_lisp_eval.c | 13 ++++- src/lisp/ao_lisp_make_const.c | 23 +++++++- src/lisp/ao_lisp_read.c | 105 ++++++++++++++++++++++++---------- src/lisp/ao_lisp_rep.c | 1 + 6 files changed, 183 insertions(+), 43 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 4fac861b..d4108662 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -27,6 +27,7 @@ #ifdef AO_LISP_MAKE_CONST #define AO_LISP_POOL_CONST 16384 extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST]; +#define _ao_lisp_atom_quote ao_lisp_atom_poly(ao_lisp_atom_intern("quote")) #else #include "ao_lisp_const.h" #endif @@ -62,6 +63,11 @@ extern uint8_t ao_lisp_exception; typedef uint16_t ao_poly; +static inline int +ao_lisp_is_const(ao_poly poly) { + return poly & AO_LISP_CONST; +} + static inline void * ao_lisp_ref(ao_poly poly) { if (poly == AO_LISP_NIL) @@ -128,6 +134,8 @@ enum ao_lisp_builtin_id { builtin_cdr, builtin_cons, builtin_quote, + builtin_set, + builtin_setq, builtin_print, builtin_plus, builtin_minus, diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e6d55797..63fb69fd 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -21,20 +21,46 @@ ao_lisp_builtin_print(ao_poly b) printf("[builtin]"); } +static int check_argc(struct ao_lisp_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_lisp_poly_cons(cons->cdr); + } + if (argc < min || argc > max) { + ao_lisp_exception |= AO_LISP_INVALID; + return 0; + } + return 1; +} + +static int check_argt(struct ao_lisp_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car; + + /* find the desired arg */ + while (argc--) + cons = ao_lisp_poly_cons(cons->cdr); + car = cons->car; + if ((!car && !nil_ok) || + ao_lisp_poly_type(car) != type) + { + ao_lisp_exception |= AO_LISP_INVALID; + return 0; + } + return 1; +} + enum math_op { math_plus, math_minus, math_times, math_divide, math_mod }; ao_poly ao_lisp_car(struct ao_lisp_cons *cons) { - if (!cons) { - ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; - } - if (!cons->car) { - ao_lisp_exception |= AO_LISP_INVALID; + if (!check_argc(cons, 1, 1)) return AO_LISP_NIL; - } - if (ao_lisp_poly_type(cons->car) != AO_LISP_CONS) { + if (!check_argt(cons, 0, AO_LISP_CONS, 0)) { ao_lisp_exception |= AO_LISP_INVALID; return AO_LISP_NIL; } @@ -91,6 +117,38 @@ ao_lisp_quote(struct ao_lisp_cons *cons) return cons->car; } +ao_poly +ao_lisp_set(struct ao_lisp_cons *cons) +{ + ao_poly atom, val; + if (!check_argc(cons, 2, 2)) + return AO_LISP_NIL; + if (!check_argt(cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + + atom = cons->car; + val = ao_lisp_poly_cons(cons->cdr)->car; + if (ao_lisp_is_const(atom)) { + ao_lisp_exception |= AO_LISP_INVALID; + return AO_LISP_NIL; + } + ao_lisp_poly_atom(atom)->val = val; + return val; +} + +ao_poly +ao_lisp_setq(struct ao_lisp_cons *cons) +{ + struct ao_lisp_cons *expand = 0; + if (!check_argc(cons, 2, 2)) + return AO_LISP_NIL; + expand = ao_lisp_cons_cons(_ao_lisp_atom_set, + ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, + ao_lisp_cons_cons(cons->car, NULL))), + ao_lisp_poly_cons(cons->cdr))); + return ao_lisp_cons_poly(expand); +} + ao_poly ao_lisp_print(struct ao_lisp_cons *cons) { @@ -196,6 +254,8 @@ ao_lisp_func_t ao_lisp_builtins[] = { [builtin_cdr] = ao_lisp_cdr, [builtin_cons] = ao_lisp_cons, [builtin_quote] = ao_lisp_quote, + [builtin_set] = ao_lisp_set, + [builtin_setq] = ao_lisp_setq, [builtin_print] = ao_lisp_print, [builtin_plus] = ao_lisp_plus, [builtin_minus] = ao_lisp_minus, diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index b13d4681..2374fdb2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -111,6 +111,9 @@ ao_lisp_eval(ao_poly v) case AO_LISP_MACRO: v = ao_lisp_func(b)(ao_lisp_poly_cons(actuals->cdr)); + DBG("macro "); DBG_POLY(ao_lisp_cons_poly(actuals)); + DBG(" -> "); DBG_POLY(v); + DBG("\n"); if (ao_lisp_poly_type(v) != AO_LISP_CONS) { ao_lisp_exception |= AO_LISP_INVALID; return AO_LISP_NIL; @@ -160,8 +163,9 @@ ao_lisp_eval(ao_poly v) DBG ("\n"); } else { ao_lisp_exception |= AO_LISP_INVALID; - return AO_LISP_NIL; } + if (ao_lisp_exception) + return AO_LISP_NIL; done_eval: if (--cons) { struct ao_lisp_cons *frame; @@ -170,10 +174,13 @@ ao_lisp_eval(ao_poly v) frame = ao_lisp_poly_cons(stack->car); actuals = ao_lisp_poly_cons(frame->car); formals = ao_lisp_poly_cons(frame->cdr); + formals_tail = NULL; /* Recompute the tail of the formals list */ - for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); - formals_tail = formal; + if (formals) { + for (formal = formals; formal->cdr != AO_LISP_NIL; formal = ao_lisp_poly_cons(formal->cdr)); + formals_tail = formal; + } stack = ao_lisp_poly_cons(stack->cdr); DBG("stack pop: stack"); DBG_CONS(stack); DBG("\n"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 21e000bf..8d3e03a9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static struct ao_lisp_builtin * ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { @@ -36,6 +37,8 @@ struct builtin_func funcs[] = { "cdr", AO_LISP_LEXPR, builtin_cdr, "cons", AO_LISP_LEXPR, builtin_cons, "quote", AO_LISP_NLAMBDA,builtin_quote, + "set", AO_LISP_LEXPR, builtin_set, + "setq", AO_LISP_MACRO, builtin_setq, "print", AO_LISP_LEXPR, builtin_print, "+", AO_LISP_LEXPR, builtin_plus, "-", AO_LISP_LEXPR, builtin_minus, @@ -51,6 +54,7 @@ main(int argc, char **argv) { int f, o; ao_poly atom, val; + struct ao_lisp_atom *a; for (f = 0; f < N_FUNC; f++) { struct ao_lisp_builtin *b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); @@ -76,14 +80,31 @@ main(int argc, char **argv) printf("#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); printf("extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); printf("#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); + + for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { + char *n = a->name, c; + printf ("#define _ao_lisp_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + printf("%c", c); + else + printf("%02x", c); + } + printf(" 0x%04x\n", ao_lisp_atom_poly(a)); + } printf("#ifdef AO_LISP_CONST_BITS\n"); printf("const uint8_t ao_lisp_const[] = {"); for (o = 0; o < ao_lisp_top; o++) { + uint8_t c; if ((o & 0xf) == 0) printf("\n\t"); else printf(" "); - printf("0x%02x,", ao_lisp_const[o]); + c = ao_lisp_const[o]; + if (' ' < c && c <= '~' && c != '\'') + printf (" '%c',", c); + else + printf("0x%02x,", c); } printf("\n};\n"); printf("#endif /* AO_LISP_CONST_BITS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index ea98b976..8fc134e5 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -375,12 +375,45 @@ static struct ao_lisp_cons *read_cons; static struct ao_lisp_cons *read_cons_tail; static struct ao_lisp_cons *read_stack; -static ao_poly -read_item(void) +static int +push_read_stack(int cons, int in_quote) +{ + if (cons) { + read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), + ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), + read_stack)); + if (!read_stack) + return 0; + } + read_cons = NULL; + read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int in_quote = 0; + if (cons) { + read_cons = ao_lisp_poly_cons(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + in_quote = ao_lisp_poly_int(read_stack->car); + read_stack = ao_lisp_poly_cons(read_stack->cdr); + for (read_cons_tail = read_cons; + read_cons_tail && read_cons_tail->cdr; + read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) + ; + } + return in_quote; +} + +ao_poly +ao_lisp_read(void) { struct ao_lisp_atom *atom; char *string; int cons; + int in_quote; ao_poly v; if (!been_here) { @@ -388,15 +421,17 @@ read_item(void) ao_lisp_root_add(&ao_lisp_cons_type, &read_cons_tail); ao_lisp_root_add(&ao_lisp_cons_type, &read_stack); } + parse_token = lex(); cons = 0; + in_quote = 0; read_cons = read_cons_tail = read_stack = 0; for (;;) { while (parse_token == OPEN) { - if (cons++) - read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(read_cons), read_stack); - read_cons = NULL; - read_cons_tail = NULL; + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 0; parse_token = lex(); } @@ -422,40 +457,48 @@ read_item(void) else v = AO_LISP_NIL; break; + case QUOTE: + if (!push_read_stack(cons, in_quote)) + return AO_LISP_NIL; + cons++; + in_quote = 1; + v = _ao_lisp_atom_quote; + break; case CLOSE: - if (cons) - v = ao_lisp_cons_poly(read_cons); - else + if (!cons) { v = AO_LISP_NIL; - if (--cons) { - read_cons = ao_lisp_poly_cons(read_stack->car); - read_stack = ao_lisp_poly_cons(read_stack->cdr); - for (read_cons_tail = read_cons; - read_cons_tail && read_cons_tail->cdr; - read_cons_tail = ao_lisp_poly_cons(read_cons_tail->cdr)) - ; + break; } + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); break; } - if (!cons) - break; + /* loop over QUOTE ends */ + for (;;) { + if (!cons) + return v; + + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); + if (!read) + return AO_LISP_NIL; + + if (read_cons_tail) + read_cons_tail->cdr = ao_lisp_cons_poly(read); + else + read_cons = read; + read_cons_tail = read; + + if (!in_quote || !read_cons->cdr) + break; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (read_cons_tail) - read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - read_cons = read; - read_cons_tail = read; + v = ao_lisp_cons_poly(read_cons); + --cons; + in_quote = pop_read_stack(cons); + } parse_token = lex(); } return v; } - -ao_poly -ao_lisp_read(void) -{ - parse_token = lex(); - return read_item(); -} diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index d26d270c..a1f9fa1f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -22,6 +22,7 @@ ao_lisp_read_eval_print(void) in = ao_lisp_read(); if (!in) break; +// printf ("in: "); ao_lisp_poly_print(in); printf("\n"); out = ao_lisp_eval(in); if (ao_lisp_exception) { if (ao_lisp_exception & AO_LISP_OOM) -- 2.30.2