From e2f4d25cd6f6f3787d4ee99264732d5b2ce23d4c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 31 Oct 2016 18:53:09 -0700 Subject: [PATCH] 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 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); + } + } -- 2.30.2