From bd881a5b85d7cd4fb82127f92f32e089499b50cb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 13:02:07 -0800 Subject: [PATCH] altos/lisp: Add non-cons cdr support The cdr of a cons can be any value; add support for lexing and printing them. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 5 +- src/lisp/ao_lisp_builtin.c | 14 ++---- src/lisp/ao_lisp_cons.c | 25 +++++++--- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_mem.c | 2 +- src/lisp/ao_lisp_read.c | 96 +++++++++++++++++++++++++------------- src/lisp/ao_lisp_read.h | 4 +- src/lisp/ao_lisp_string.c | 2 +- 8 files changed, 98 insertions(+), 52 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 980514cc..79f8fcc3 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -499,7 +499,10 @@ ao_lisp_stack_fetch(int id) { extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); +ao_lisp_cons_cons(ao_poly car, ao_poly cdr); + +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr); extern struct ao_lisp_cons *ao_lisp_cons_free_list; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 902f60e2..5a960873 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -190,11 +190,9 @@ ao_lisp_cons(struct ao_lisp_cons *cons) ao_poly car, cdr; if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - 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))); + return ao_lisp__cons(car, cdr); } ao_poly @@ -247,14 +245,12 @@ ao_lisp_set(struct ao_lisp_cons *cons) ao_poly ao_lisp_setq(struct ao_lisp_cons *cons) { - struct ao_lisp_cons *expand = 0; 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, - ao_lisp_cons_cons(cons->car, NULL))), - ao_lisp_poly_cons(cons->cdr))); - return ao_lisp_cons_poly(expand); + return ao_lisp__cons(_ao_lisp_atom_set, + ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, + ao_lisp__cons(cons->car, AO_LISP_NIL)), + cons->cdr)); } ao_poly diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index d2b60c9a..81a16a7a 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -72,7 +72,7 @@ const struct ao_lisp_type ao_lisp_cons_type = { struct ao_lisp_cons *ao_lisp_cons_free_list; struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) +ao_lisp_cons_cons(ao_poly car, ao_poly cdr) { struct ao_lisp_cons *cons; @@ -81,18 +81,24 @@ ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); } else { ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); + ao_lisp_poly_stash(1, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); + cdr = ao_lisp_poly_fetch(1); if (!cons) return NULL; } cons->car = car; - cons->cdr = ao_lisp_cons_poly(cdr); + cons->cdr = cdr; return cons; } +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr) +{ + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); +} + void ao_lisp_cons_free(struct ao_lisp_cons *cons) { @@ -114,8 +120,15 @@ ao_lisp_cons_print(ao_poly c) if (!first) printf(" "); ao_lisp_poly_print(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - first = 0; + c = cons->cdr; + if (ao_lisp_poly_type(c) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(c); + first = 0; + } else { + printf(" . "); + ao_lisp_poly_print(c); + cons = NULL; + } } printf(")"); } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3be7c9c4..3e68d14a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -210,7 +210,7 @@ ao_lisp_eval_formal(void) } /* Append formal to list of values */ - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); if (!formal) return 0; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d067ea07..d7c8d7a6 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -437,7 +437,7 @@ dump_busy(void) #define DUMP_BUSY() #endif -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { +static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_CONS] = &ao_lisp_cons_type, [AO_LISP_INT] = NULL, [AO_LISP_STRING] = &ao_lisp_string_type, diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 84ef2a61..550f62c2 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -62,7 +62,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE, /* . */ + PRINTABLE|DOTC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -262,7 +262,7 @@ static inline void end_token(void) { } static int -lex(void) +_lex(void) { int c; @@ -295,6 +295,11 @@ lex(void) return QUOTE; } } + if (lex_class & (DOTC)) { + add_token(c); + end_token(); + return DOT; + } if (lex_class & TWIDDLE) { token_int = lexc(); return NUM; @@ -355,21 +360,32 @@ lex(void) } } +static inline int lex(void) +{ + int parse_token = _lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + static int parse_token; struct ao_lisp_cons *ao_lisp_read_cons; struct ao_lisp_cons *ao_lisp_read_cons_tail; struct ao_lisp_cons *ao_lisp_read_stack; +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + static int -push_read_stack(int cons, int in_quote) +push_read_stack(int cons, int read_state) { - DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); + DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); DBG_IN(); if (cons) { ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), - ao_lisp_read_stack)); + ao_lisp__cons(ao_lisp_int_poly(read_state), + ao_lisp_cons_poly(ao_lisp_read_stack))); if (!ao_lisp_read_stack) return 0; } @@ -381,11 +397,11 @@ push_read_stack(int cons, int in_quote) static int pop_read_stack(int cons) { - int in_quote = 0; + int read_state = 0; if (cons) { ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); + read_state = ao_lisp_poly_int(ao_lisp_read_stack->car); ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); for (ao_lisp_read_cons_tail = ao_lisp_read_cons; ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; @@ -397,8 +413,8 @@ pop_read_stack(int cons) ao_lisp_read_stack = 0; } DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); - return in_quote; + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); + return read_state; } ao_poly @@ -407,23 +423,21 @@ ao_lisp_read(void) struct ao_lisp_atom *atom; char *string; int cons; - int in_quote; + int read_state; ao_poly v; - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; - in_quote = 0; + read_state = 0; ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; for (;;) { + parse_token = lex(); while (parse_token == OPEN) { - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 0; + read_state = 0; parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); } switch (parse_token) { @@ -451,10 +465,10 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case QUOTE: - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 1; + read_state |= READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: @@ -464,8 +478,19 @@ ao_lisp_read(void) } v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = pop_read_stack(cons); break; + case DOT: + if (!cons) { + ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); + return AO_LISP_NIL; + } + if (!ao_lisp_read_cons) { + ao_lisp_error(AO_LISP_INVALID, ". first in cons"); + return AO_LISP_NIL; + } + read_state |= READ_SAW_DOT; + continue; } /* loop over QUOTE ends */ @@ -473,26 +498,33 @@ ao_lisp_read(void) if (!cons) return v; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (!read) + if (read_state & READ_DONE_DOT) { + ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); return AO_LISP_NIL; + } - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; + if (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_lisp_read_cons_tail->cdr = v; + } else { + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); + if (!read) + return AO_LISP_NIL; - if (!in_quote || !ao_lisp_read_cons->cdr) + if (ao_lisp_read_cons_tail) + ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); + else + ao_lisp_read_cons = read; + ao_lisp_read_cons_tail = read; + } + + if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) break; v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = pop_read_stack(cons); } - - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); } return v; } diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 1c994d56..30dcac3f 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -22,6 +22,7 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 +# define DOT 7 /* * character classes @@ -42,8 +43,9 @@ # define VBAR 0x00001000 /* | */ # define TWIDDLE 0x00002000 /* ~ */ # define STRINGC 0x00004000 /* " */ +# define DOTC 0x00008000 /* . */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA|DOTC) # 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 cd7b27a9..af23f7b3 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -103,7 +103,7 @@ ao_lisp_string_unpack(char *a) ao_lisp_cons_stash(0, cons); ao_lisp_cons_stash(1, tail); ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); a = ao_lisp_string_fetch(0); cons = ao_lisp_cons_fetch(0); tail = ao_lisp_cons_fetch(1); -- 2.30.2