From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_cons.c | 201 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 201 insertions(+) create mode 100644 src/scheme/ao_scheme_cons.c (limited to 'src/scheme/ao_scheme_cons.c') diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * 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_scheme.h" + +static void cons_mark(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + for (;;) { + ao_poly cdr = cons->cdr; + + ao_scheme_poly_mark(cons->car, 1); + if (!cdr) + break; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + break; + } + cons = ao_scheme_poly_cons(cdr); + if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) + break; + } +} + +static int cons_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_cons); +} + +static void cons_move(void *addr) +{ + struct ao_scheme_cons *cons = addr; + + if (!cons) + return; + + for (;;) { + ao_poly cdr; + struct ao_scheme_cons *c; + int ret; + + MDBG_MOVE("cons_move start %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + (void) ao_scheme_poly_move(&cons->car, 1); + cdr = cons->cdr; + if (!cdr) + break; + if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_poly_move(&cons->cdr, 0); + break; + } + c = ao_scheme_poly_cons(cdr); + ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); + if (c != ao_scheme_poly_cons(cons->cdr)) + cons->cdr = ao_scheme_cons_poly(c); + MDBG_MOVE("cons_move end %d (%d, %d)\n", + MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); + if (ret) + break; + cons = c; + } +} + +const struct ao_scheme_type ao_scheme_cons_type = { + .mark = cons_mark, + .size = cons_size, + .move = cons_move, + .name = "cons", +}; + +struct ao_scheme_cons *ao_scheme_cons_free_list; + +struct ao_scheme_cons * +ao_scheme_cons_cons(ao_poly car, ao_poly cdr) +{ + struct ao_scheme_cons *cons; + + if (ao_scheme_cons_free_list) { + cons = ao_scheme_cons_free_list; + ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); + } else { + ao_scheme_poly_stash(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + if (!cons) + return NULL; + } + cons->car = car; + cons->cdr = cdr; + return cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_cdr(struct ao_scheme_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_SCHEME_NIL) + return NULL; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + return NULL; + } + return ao_scheme_poly_cons(cdr); +} + +ao_poly +ao_scheme__cons(ao_poly car, ao_poly cdr) +{ + return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); +} + +void +ao_scheme_cons_free(struct ao_scheme_cons *cons) +{ +#if DBG_FREE_CONS + ao_scheme_cons_check(cons); +#endif + while (cons) { + ao_poly cdr = cons->cdr; + cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); + ao_scheme_cons_free_list = cons; + cons = ao_scheme_poly_cons(cdr); + } +} + +void +ao_scheme_cons_write(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_poly_cons(cons->cdr); + } + return len; +} -- cgit v1.2.3 From abb856cd66e00d739e4efb1930b5c168eaf48029 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:34 -0800 Subject: altos/scheme: Avoid crashing with non-list in length Use ao_scheme_cons_cdr to fetch the next list element as that returns NULL for non-cons elements. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_cons.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/scheme/ao_scheme_cons.c') diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 03dad956..21ee10cc 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -195,7 +195,7 @@ ao_scheme_cons_length(struct ao_scheme_cons *cons) int len = 0; while (cons) { len++; - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } return len; } -- cgit v1.2.3 From b72638e60b6636b479b79bbf0047cf7409f58820 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:51:25 -0800 Subject: altos/scheme: add list-copy A lot easier as a built-in; the obvious scheme version is recursive. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 3 +++ src/scheme/ao_scheme_builtin.c | 13 +++++++++++++ src/scheme/ao_scheme_builtin.txt | 1 + src/scheme/ao_scheme_cons.c | 38 +++++++++++++++++++++++++++++++++++++- 4 files changed, 54 insertions(+), 1 deletion(-) (limited to 'src/scheme/ao_scheme_cons.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4655b2a9..2fa1ed60 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -634,6 +634,9 @@ ao_scheme_cons_display(ao_poly); int ao_scheme_cons_length(struct ao_scheme_cons *cons); +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons); + /* string */ extern const struct ao_scheme_type ao_scheme_string_type; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 397ce032..6f9e1390 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -197,6 +197,19 @@ ao_scheme_do_length(struct ao_scheme_cons *cons) return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); } +ao_poly +ao_scheme_do_list_copy(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *new; + + if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); + return ao_scheme_cons_poly(new); +} + ao_poly ao_scheme_do_quote(struct ao_scheme_cons *cons) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index b7261ce1..17f5ea0c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -8,6 +8,7 @@ f_lambda cdr f_lambda cons f_lambda last f_lambda length +f_lambda list_copy list-copy nlambda quote atom quasiquote atom unquote diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 21ee10cc..02512e15 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -112,7 +112,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) if (cdr == AO_SCHEME_NIL) return NULL; if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } return ao_scheme_poly_cons(cdr); @@ -124,6 +124,42 @@ ao_scheme__cons(ao_poly car, ao_poly cdr) return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); } +struct ao_scheme_cons * +ao_scheme_cons_copy(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *head = NULL; + struct ao_scheme_cons *tail = NULL; + + while (cons) { + struct ao_scheme_cons *new; + ao_poly cdr; + + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, head); + ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); + new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cons = ao_scheme_cons_fetch(0); + head = ao_scheme_cons_fetch(1); + tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); + if (!new) + return AO_SCHEME_NIL; + new->car = cons->car; + new->cdr = AO_SCHEME_NIL; + if (!head) + head = new; + else + tail->cdr = ao_scheme_cons_poly(new); + tail = new; + cdr = cons->cdr; + if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + tail->cdr = cdr; + break; + } + cons = ao_scheme_poly_cons(cdr); + } + return head; +} + void ao_scheme_cons_free(struct ao_scheme_cons *cons) { -- cgit v1.2.3