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_builtin.c | 868 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 868 insertions(+) create mode 100644 src/scheme/ao_scheme_builtin.c (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * 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" +#include +#include + +static int +builtin_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_builtin); +} + +static void +builtin_mark(void *addr) +{ + (void) addr; +} + +static void +builtin_move(void *addr) +{ + (void) addr; +} + +const struct ao_scheme_type ao_scheme_builtin_type = { + .size = builtin_size, + .mark = builtin_mark, + .move = builtin_move +}; + +#ifdef AO_SCHEME_MAKE_CONST + +#define AO_SCHEME_BUILTIN_CASENAME +#include "ao_scheme_builtin.h" + +char *ao_scheme_args_name(uint8_t args) { + args &= AO_SCHEME_FUNC_MASK; + switch (args) { + case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; + case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; + case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; + default: return "???"; + } +} +#else + +#define AO_SCHEME_BUILTIN_ARRAYNAME +#include "ao_scheme_builtin.h" + +static char * +ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { + if (b < _builtin_last) + return ao_scheme_poly_atom(builtin_names[b])->name; + return "???"; +} + +static const ao_poly ao_scheme_args_atoms[] = { + [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, + [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, + [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, +}; + +char * +ao_scheme_args_name(uint8_t args) +{ + args &= AO_SCHEME_FUNC_MASK; + if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) + return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; + return "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + printf("%s", ao_scheme_builtin_name(builtin->func)); +} + +ao_poly +ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) +{ + int argc = 0; + + while (cons && argc <= max) { + argc++; + cons = ao_scheme_cons_cdr(cons); + } + if (argc < min || argc > max) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_arg(struct ao_scheme_cons *cons, int argc) +{ + if (!cons) + return AO_SCHEME_NIL; + while (argc--) { + if (!cons) + return AO_SCHEME_NIL; + cons = ao_scheme_cons_cdr(cons); + } + return cons->car; +} + +ao_poly +ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) +{ + ao_poly car = ao_scheme_arg(cons, argc); + + if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) + return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->car; +} + +ao_poly +ao_scheme_do_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(cons->car)->cdr; +} + +ao_poly +ao_scheme_do_cons(struct ao_scheme_cons *cons) +{ + ao_poly car, cdr; + if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) + return AO_SCHEME_NIL; + car = ao_scheme_arg(cons, 0); + cdr = ao_scheme_arg(cons, 1); + return ao_scheme__cons(car, cdr); +} + +ao_poly +ao_scheme_do_last(struct ao_scheme_cons *cons) +{ + struct ao_scheme_cons *list; + if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); + list; + list = ao_scheme_cons_cdr(list)) + { + if (!list->cdr) + return list->car; + } + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_length(struct ao_scheme_cons *cons) +{ + 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; + return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_quote(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) + return AO_SCHEME_NIL; + return ao_scheme_arg(cons, 0); +} + +ao_poly +ao_scheme_do_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_def(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_setq(struct ao_scheme_cons *cons) +{ + ao_poly name; + if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) + return AO_SCHEME_NIL; + name = cons->car; + if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) + return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); + if (!ao_scheme_atom_ref(name, NULL)) + return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); + return ao_scheme__cons(_ao_scheme_atom_set, + ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, + ao_scheme__cons(name, AO_SCHEME_NIL)), + cons->cdr)); +} + +ao_poly +ao_scheme_do_cond(struct ao_scheme_cons *cons) +{ + ao_scheme_set_cond(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_begin(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_begin; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_while(struct ao_scheme_cons *cons) +{ + ao_scheme_stack->state = eval_while; + ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); + return AO_SCHEME_NIL; +} + +ao_poly +ao_scheme_do_write(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_write(val); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + printf("\n"); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_display(struct ao_scheme_cons *cons) +{ + ao_poly val = AO_SCHEME_NIL; + while (cons) { + val = cons->car; + ao_scheme_poly_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *cons = cons; + ao_poly ret = AO_SCHEME_NIL; + + for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly car = cons->car; + uint8_t rt = ao_scheme_poly_type(ret); + uint8_t ct = ao_scheme_poly_type(car); + + if (cons == orig_cons) { + ret = car; + if (cons->cdr == AO_SCHEME_NIL) { + switch (op) { + case builtin_minus: + if (ao_scheme_integer_typep(ct)) + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + break; + case builtin_quotient: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); + if (r % c != 0 && (c < 0) != (r < 0)) + r = r / c - 1; + else + r = r / c; + break; + case builtin_remainder: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_scheme_integer_poly(r); + } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { + float r, c; + inexact: + r = ao_scheme_poly_number(ret); + c = ao_scheme_poly_number(car); + switch(op) { + case builtin_plus: + r += c; + break; + case builtin_minus: + r -= c; + break; + case builtin_times: + r *= c; + break; + case builtin_divide: + r /= c; + break; + case builtin_quotient: + case builtin_remainder: + case builtin_modulo: + return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); + default: + break; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + else + return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); + } + return ret; +} + +ao_poly +ao_scheme_do_plus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_plus); +} + +ao_poly +ao_scheme_do_minus(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_minus); +} + +ao_poly +ao_scheme_do_times(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_times); +} + +ao_poly +ao_scheme_do_divide(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_divide); +} + +ao_poly +ao_scheme_do_quotient(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_quotient); +} + +ao_poly +ao_scheme_do_modulo(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_modulo); +} + +ao_poly +ao_scheme_do_remainder(struct ao_scheme_cons *cons) +{ + return ao_scheme_math(cons, builtin_remainder); +} + +ao_poly +ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) +{ + ao_poly left; + + if (!cons) + return _ao_scheme_bool_true; + + left = cons->car; + for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { + ao_poly right = cons->car; + + if (op == builtin_equal) { + if (left != right) + return _ao_scheme_bool_false; + } else { + uint8_t lt = ao_scheme_poly_type(left); + uint8_t rt = ao_scheme_poly_type(right); + if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { + int32_t l = ao_scheme_poly_integer(left); + int32_t r = ao_scheme_poly_integer(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + switch (op) { + case builtin_less: + if (!(c < 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(c > 0)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(c <= 0)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(c >= 0)) + return _ao_scheme_bool_false; + break; + default: + break; + } + } + } + left = right; + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_equal); +} + +ao_poly +ao_scheme_do_less(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less); +} + +ao_poly +ao_scheme_do_greater(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater); +} + +ao_poly +ao_scheme_do_less_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_less_equal); +} + +ao_poly +ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) +{ + return ao_scheme_compare(cons, builtin_greater_equal); +} + +ao_poly +ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) + return AO_SCHEME_NIL; + return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); +} + +ao_poly +ao_scheme_do_flush_output(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_os_flush(); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_led(struct ao_scheme_cons *cons) +{ + ao_poly led; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + led = ao_scheme_arg(cons, 0); + ao_scheme_os_led(ao_scheme_poly_int(led)); + return led; +} + +ao_poly +ao_scheme_do_delay(struct ao_scheme_cons *cons) +{ + ao_poly delay; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(delay)); + return delay; +} + +ao_poly +ao_scheme_do_eval(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_sexpr; + return cons->car; +} + +ao_poly +ao_scheme_do_apply(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) + return AO_SCHEME_NIL; + ao_scheme_stack->state = eval_apply; + return ao_scheme_cons_poly(cons); +} + +ao_poly +ao_scheme_do_read(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) + return AO_SCHEME_NIL; + return ao_scheme_read(); +} + +ao_poly +ao_scheme_do_collect(struct ao_scheme_cons *cons) +{ + int free; + (void) cons; + free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); + return ao_scheme_int_poly(free); +} + +ao_poly +ao_scheme_do_nullp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_not(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) + return _ao_scheme_bool_true; + else + return _ao_scheme_bool_false; +} + +static ao_poly +ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_pairp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_stringp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_STRING, cons); +} + +ao_poly +ao_scheme_do_symbolp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); +} + +ao_poly +ao_scheme_do_booleanp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); +} + +ao_poly +ao_scheme_do_procedurep(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_scheme_do_listp(struct ao_scheme_cons *cons) +{ + ao_poly v; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + v = ao_scheme_arg(cons, 0); + for (;;) { + if (v == AO_SCHEME_NIL) + return _ao_scheme_bool_true; + if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + return _ao_scheme_bool_false; + v = ao_scheme_poly_cons(v)->cdr; + } +} + +ao_poly +ao_scheme_do_set_car(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); +} + +ao_poly +ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) + return AO_SCHEME_NIL; + return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +ao_poly +ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + + return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_read_char(struct ao_scheme_cons *cons) +{ + int c; + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + c = getchar(); + return ao_scheme_int_poly(c); +} + +ao_poly +ao_scheme_do_write_char(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + return AO_SCHEME_NIL; + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_exit(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + ao_scheme_exception |= AO_SCHEME_EXIT; + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) +{ + int jiffy; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + jiffy = ao_scheme_os_jiffy(); + return (ao_scheme_int_poly(jiffy)); +} + +ao_poly +ao_scheme_do_current_second(struct ao_scheme_cons *cons) +{ + int second; + + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; + return (ao_scheme_int_poly(second)); +} + +ao_poly +ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) + return AO_SCHEME_NIL; + return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#define AO_SCHEME_BUILTIN_FUNCS +#include "ao_scheme_builtin.h" -- cgit v1.2.3 From 1133130986a78628ea297ce1f6a023baf4382d8f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 9 Dec 2017 16:56:20 -0800 Subject: altos/scheme: Let readline know if there's a list in progress This lets the interactive prompt change based on what state the lexer is in Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +- src/scheme/ao_scheme_builtin.c | 2 +- src/scheme/ao_scheme_const.scheme | 813 ++++++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_float.c | 6 +- src/scheme/ao_scheme_read.c | 40 +- src/scheme/test/ao_scheme_test.c | 2 +- 6 files changed, 845 insertions(+), 24 deletions(-) create mode 100644 src/scheme/ao_scheme_const.scheme (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4589f8a5..10518716 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -31,7 +31,7 @@ typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; -#ifdef AO_SCHEME_SAVE +#if AO_SCHEME_SAVE struct ao_scheme_os_save { ao_poly atoms; @@ -77,6 +77,9 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #ifndef AO_SCHEME_POOL #define AO_SCHEME_POOL 3072 #endif +#ifndef AO_SCHEME_POOL_EXTRA +#define AO_SCHEME_POOL_EXTRA 0 +#endif extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); #endif @@ -745,6 +748,7 @@ char * ao_scheme_args_name(uint8_t args); /* read */ +extern int ao_scheme_read_list; extern struct ao_scheme_cons *ao_scheme_read_cons; extern struct ao_scheme_cons *ao_scheme_read_cons_tail; extern struct ao_scheme_cons *ao_scheme_read_stack; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 49f218f6..aa818646 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -636,7 +636,7 @@ ao_scheme_do_collect(struct ao_scheme_cons *cons) int free; (void) cons; free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_int_poly(free); + return ao_scheme_integer_poly(free); } ao_poly diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; 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. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (name value) + (list + def + (list quote name) + value) + ) + ) + +(begin + (def! append + (lambda args + (def! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + + (def! append-lists + (lambda (lists) + (cond ((null? lists) lists) + ((null? (cdr lists)) (car lists)) + (else (append-list (car lists) (append-lists (cdr lists)))) + ) + ) + ) + (append-lists args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(begin + (def! or + (macro l + (def! _or + (lambda (l) + (cond ((null? l) #f) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l)) + (list + 'else + (_or (cdr l)) + ) + ) + ) + ) + ) + ) + (_or l))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro l + (def! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + +(begin + (def! quasiquote + (macro (x) + (def! constant? + ; A constant value is either a pair starting with quote, + ; or anything which is neither a pair nor a symbol + + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) + ) + (else + (not (symbol? exp)) + ) + ) + ) + ) + (def! combine-skeletons + (lambda (left right exp) + (cond + ((and (constant? left) (constant? right)) + (cond ((and (eqv? (eval left) (car exp)) + (eqv? (eval right) (cdr exp))) + (list 'quote exp) + ) + (else + (list 'quote (cons (eval left) (eval right))) + ) + ) + ) + ((null? right) + (list 'list left) + ) + ((and (pair? right) (eq? (car right) 'list)) + (cons 'list (cons left (cdr right))) + ) + (else + (list 'cons left right) + ) + ) + ) + ) + + (def! expand-quasiquote + (lambda (exp nesting) + (cond + + ; non cons -- constants + ; themselves, others are + ; quoted + + ((not (pair? exp)) + (cond ((constant? exp) + exp + ) + (else + (list 'quote exp) + ) + ) + ) + + ; check for an unquote exp and + ; add the param unquoted + + ((and (eq? (car exp) 'unquote) (= (length exp) 2)) + (cond ((= nesting 0) + (car (cdr exp)) + ) + (else + (combine-skeletons ''unquote + (expand-quasiquote (cdr exp) (- nesting 1)) + exp)) + ) + ) + + ; nested quasi-quote -- + ; construct the right + ; expression + + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) + + ; check for an + ; unquote-splicing member, + ; compute the expansion of the + ; value and append the rest of + ; the quasiquote result to it + + ((and (pair? (car exp)) + (eq? (car (car exp)) 'unquote-splicing) + (= (length (car exp)) 2)) + (cond ((= nesting 0) + (list 'append (car (cdr (car exp))) + (expand-quasiquote (cdr exp) nesting)) + ) + (else + (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) + (expand-quasiquote (cdr exp) nesting) + exp)) + ) + ) + + ; for other lists, just glue + ; the expansion of the first + ; element to the expansion of + ; the rest of the list + + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (def! result (expand-quasiquote x 0)) + result + ) + ) + 'quasiquote) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) + ; + +(begin + (def! define + (macro (first . rest) + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) `(eq? ,value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) `(> ,value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) `(< ,value 0))) + +(negative? 12) +(negative? -12) + +(define (abs x) (if (>= x 0) x (- x))) + +(abs 12) +(abs -12) + +(define max (lambda (first . rest) + (while (not (null? rest)) + (cond ((< first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (first . rest) + (while (not (null? rest)) + (cond ((> first (car rest)) + (set! first (car rest))) + ) + (set! rest (cdr rest)) + ) + first) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + +(define (list-ref x k) + (car (list-tail x k)) + ) + + ; define a set of local + ; variables all at once 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)) (set! y (+ x 1)) y) + +(define let + (macro (vars . exprs) + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-vals vars) + (cond ((not (null? vars)) + (cons (cond ((null? (cdr (car vars))) ()) + (else + (car (cdr (car vars)))) + ) + (make-vals (cdr vars)))) + (else ()) + ) + ) + ; prepend the set operations + ; to the expressions + + ; build the lambda. + + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) + ) + + +(let ((x 1) (y)) (set! y 2) (+ x y)) + + ; define a set of local + ; variables one at a time 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)) (set! y (+ x 1)) y) + +(define let* + (macro (vars . exprs) + + ; + ; make the list of names in the let + ; + + (define (make-names vars) + (cond ((not (null? vars)) + (cons (car (car vars)) + (make-names (cdr vars)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (make-exprs vars exprs) + (cond ((null? vars) exprs) + (else + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) + ; build the lambda. + + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) + ) + +(let* ((x 1) (y x)) (+ x y)) + +(define when (macro (test . l) `(cond (,test ,@l)))) + +(when #t (write 'when)) + +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) + +(unless #f (write 'unless)) + +(define (reverse list) + (let ((result ())) + (while (not (null? list)) + (set! result (cons (car list) result)) + (set! list (cdr list)) + ) + result) + ) + +(reverse '(1 2 3)) + +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((and (pair? a) (pair? b)) + (and (equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + (else #f) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj list . test?) + (cond ((null? list) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car list)) + list + (member obj (cdr list) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj list) (member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(memv '(2) '((1) (2) (3))) + +(define (_assoc obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(define (assq obj list) (_assoc obj list eq?)) +(define (assv obj list) (_assoc obj list eqv?)) +(define (assoc obj list) (_assoc obj list equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assv 'b '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define char? integer?) + +(char? #\q) +(char? "h") + +(define (char-upper-case? c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(define (char-lower-case? c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(define (char-numeric? c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(define (char->integer c) c) +(define (integer->char c) char-integer) + +(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) + +(char-downcase #\a) +(char-downcase #\B) +(char-downcase #\0) +(char-downcase #\space) + +(define string (lambda chars (list->string chars))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (proc . lists) + (define (args lists) + (cond ((null? lists) ()) + (else + (cons (caar lists) (args (cdr lists))) + ) + ) + ) + (define (next lists) + (cond ((null? lists) ()) + (else + (cons (cdr (car lists)) (next (cdr lists))) + ) + ) + ) + (define (domap lists) + (cond ((null? (car lists)) ()) + (else + (cons (apply proc (args lists)) (domap (next lists))) + ) + ) + ) + (domap lists) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (proc . lists) + (apply map proc lists) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) + +(define string-map (lambda (proc . strings) + (list->string (apply map proc (_string-ml strings)))))) + +(string-map (lambda (x) (+ 1 x)) "HAL") + +(define string-for-each (lambda (proc . strings) + (apply for-each proc (_string-ml strings)))) + +(string-for-each write-char "IBM\n") + +(define (newline) (write-char #\newline)) + +(newline) + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (write "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + + + ; `q -> (quote q) + ; `(q) -> (append (quote (q))) + ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) + ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) + + + +`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) + + +(define repeat + (macro (count . rest) + (define counter '__count__) + (cond ((pair? count) + (set! counter (car count)) + (set! count (cadr count)) + ) + ) + `(let ((,counter 0) + (__max__ ,count) + ) + (while (< ,counter __max__) + ,@rest + (set! ,counter (+ ,counter 1)) + ) + ) + ) + ) + +(repeat 2 (write 'hello)) +(repeat (x 3) (write 'goodbye x)) + +(define case + (macro (test . l) + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (define (_unarrow l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)) + ) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (define (_case l) + + (cond ((null? l) ()) + + ; else case + + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) + + ; regular case + + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + ) + ) + + ; now construct the overall + ; expression, using a lambda + ; to hold the computed value + ; of the test expression + + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) + +(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index 541f0264..99249030 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -39,6 +39,10 @@ const struct ao_scheme_type ao_scheme_float_type = { .name = "float", }; +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + void ao_scheme_float_write(ao_poly p) { @@ -54,7 +58,7 @@ ao_scheme_float_write(ao_poly p) printf("+"); printf("inf.0"); } else - printf ("%g", f->value); + printf (FLOAT_FORMAT, v); } float diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 6b1e9d66..30e29441 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -151,7 +151,7 @@ static const uint16_t lex_classes[128] = { static int lex_unget_c; static inline int -lex_get() +lex_get(void) { int c; if (lex_unget_c) { @@ -244,7 +244,7 @@ lex_quoted(void) } } -#define AO_SCHEME_TOKEN_MAX 32 +#define AO_SCHEME_TOKEN_MAX 128 static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; @@ -470,6 +470,7 @@ static inline int lex(void) static int parse_token; +int ao_scheme_read_list; struct ao_scheme_cons *ao_scheme_read_cons; struct ao_scheme_cons *ao_scheme_read_cons_tail; struct ao_scheme_cons *ao_scheme_read_stack; @@ -479,11 +480,11 @@ struct ao_scheme_cons *ao_scheme_read_stack; #define READ_DONE_DOT 0x04 static int -push_read_stack(int cons, int read_state) +push_read_stack(int read_state) { RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); RDBG_IN(); - if (cons) { + if (ao_scheme_read_list) { ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), ao_scheme__cons(ao_scheme_int_poly(read_state), ao_scheme_cons_poly(ao_scheme_read_stack))); @@ -496,10 +497,10 @@ push_read_stack(int cons, int read_state) } static int -pop_read_stack(int cons) +pop_read_stack(void) { int read_state = 0; - if (cons) { + if (ao_scheme_read_list) { ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); @@ -523,19 +524,18 @@ ao_scheme_read(void) { struct ao_scheme_atom *atom; char *string; - int cons; int read_state; ao_poly v = AO_SCHEME_NIL; - cons = 0; + ao_scheme_read_list = 0; read_state = 0; ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); while (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = 0; parse_token = lex(); } @@ -543,7 +543,7 @@ ao_scheme_read(void) switch (parse_token) { case END: default: - if (cons) + if (ao_scheme_read_list) ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); return _ao_scheme_atom_eof; break; @@ -577,9 +577,9 @@ ao_scheme_read(void) case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = READ_IN_QUOTE; switch (parse_token) { case QUOTE: @@ -597,16 +597,16 @@ ao_scheme_read(void) } break; case CLOSE: - if (!cons) { + if (!ao_scheme_read_list) { v = AO_SCHEME_NIL; break; } v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); break; case DOT: - if (!cons) { + if (!ao_scheme_read_list) { ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); return AO_SCHEME_NIL; } @@ -620,7 +620,7 @@ ao_scheme_read(void) /* loop over QUOTE ends */ for (;;) { - if (!cons) + if (!ao_scheme_read_list) return v; if (read_state & READ_DONE_DOT) { @@ -647,8 +647,8 @@ ao_scheme_read(void) break; v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); } } return v; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 15c71203..686e7169 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -78,7 +78,7 @@ ao_scheme_getc(void) return getc(ao_scheme_file); if (newline) { - if (ao_scheme_read_stack) + if (ao_scheme_read_list) printf("+ "); else printf("> "); -- cgit v1.2.3 From 17fe6de833cccb6d43d0ac0ed84a4faaa3463a09 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:00 -0800 Subject: altos/scheme: Add vectors Constant time and smaller can be a feature. Signed-off-by: Keith Packard --- src/scheme/Makefile-inc | 3 +- src/scheme/README | 2 +- src/scheme/ao_scheme.h | 48 ++- src/scheme/ao_scheme_builtin.c | 65 +++- src/scheme/ao_scheme_builtin.txt | 7 + src/scheme/ao_scheme_const.lisp | 813 --------------------------------------- src/scheme/ao_scheme_eval.c | 8 +- src/scheme/ao_scheme_mem.c | 1 + src/scheme/ao_scheme_poly.c | 4 + src/scheme/ao_scheme_read.c | 14 +- src/scheme/ao_scheme_read.h | 1 + 11 files changed, 139 insertions(+), 827 deletions(-) delete mode 100644 src/scheme/ao_scheme_const.lisp (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index d23ee3d7..1a080a4e 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -15,7 +15,8 @@ SCHEME_SRCS=\ ao_scheme_rep.c \ ao_scheme_save.c \ ao_scheme_stack.c \ - ao_scheme_error.c + ao_scheme_error.c \ + ao_scheme_vector.c SCHEME_HDRS=\ ao_scheme.h \ diff --git a/src/scheme/README b/src/scheme/README index 98932b44..a18457fd 100644 --- a/src/scheme/README +++ b/src/scheme/README @@ -5,6 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; (have classic macros) +* No syntax-rules * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 10518716..89616617 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -104,7 +104,8 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_BOOL 10 #define AO_SCHEME_BIGINT 11 #define AO_SCHEME_FLOAT 12 -#define AO_SCHEME_NUM_TYPE 13 +#define AO_SCHEME_VECTOR 13 +#define AO_SCHEME_NUM_TYPE 14 /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -192,6 +193,13 @@ struct ao_scheme_float { float value; }; +struct ao_scheme_vector { + uint8_t type; + uint8_t pad1; + uint16_t length; + ao_poly vals[]; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_scheme_int_bigint(int32_t i) { @@ -500,6 +508,18 @@ ao_scheme_poly_float(ao_poly poly) float ao_scheme_poly_number(ao_poly p); +static inline ao_poly +ao_scheme_vector_poly(struct ao_scheme_vector *v) +{ + return ao_scheme_poly(v, AO_SCHEME_OTHER); +} + +static inline struct ao_scheme_vector * +ao_scheme_poly_vector(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + /* memory functions */ extern int ao_scheme_collects[2]; @@ -680,6 +700,32 @@ void ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill); + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i); + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_vector_to_list(struct ao_scheme_vector *vector); + +extern const struct ao_scheme_type ao_scheme_vector_type; + /* prim */ void ao_scheme_poly_write(ao_poly p); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index aa818646..ae96df7f 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -267,7 +267,6 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) if (cons) printf(" "); } - printf("\n"); return _ao_scheme_bool_true; } @@ -751,7 +750,7 @@ ao_poly ao_scheme_do_listp(struct ao_scheme_cons *cons) { ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); for (;;) { @@ -864,5 +863,67 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +ao_poly +ao_scheme_do_vector(struct ao_scheme_cons *cons) +{ + return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); +} + +ao_poly +ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); +} + +ao_poly +ao_scheme_do_vector_set(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); +} + +ao_poly +ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); +} + +ao_poly +ao_scheme_do_vector_length(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) + return AO_SCHEME_NIL; + return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); +} + +ao_poly +ao_scheme_do_vectorp(struct ao_scheme_cons *cons) +{ + return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); +} + #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index cb65e252..e7b3d75c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -66,3 +66,10 @@ f_lambda finitep finite? f_lambda infinitep infinite? f_lambda inexactp inexact? f_lambda sqrt +f_lambda vector_ref vector-ref +f_lambda vector_set vector-set! +f_lambda vector +f_lambda list_to_vector list->vector +f_lambda vector_to_list vector->list +f_lambda vector_length vector-length +f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/scheme/ao_scheme_const.lisp +++ /dev/null @@ -1,813 +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. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(or #f #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((list? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(define (cadr l) (car (cdr l))) - -(define (cdar l) (cdr (car l))) - -(define (caddr l) (car (cdr (cdr l)))) - - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - - ; define a set of local - ; variables all at once 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)) (set! y (+ x 1)) y) - -(define let - (macro (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - - ; define a set of local - ; variables one at a time 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)) (set! y (+ x 1)) y) - -(define let* - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) - ) - -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) - (if (null? list) - #f - (if (test? obj (caar list)) - (car list) - (_assoc obj (cdr list) test?) - ) - ) - ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define (char->integer c) c) -(define (integer->char c) char-integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define string (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (proc . lists) - (define (args lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (args (cdr lists))) - ) - ) - ) - (define (next lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (next (cdr lists))) - ) - ) - ) - (define (domap lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (args lists)) (domap (next lists))) - ) - ) - ) - (domap lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9b3cf63e..907ecf0b 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -108,13 +108,7 @@ ao_scheme_eval_sexpr(void) DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); /* fall through */ - case AO_SCHEME_BOOL: - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - case AO_SCHEME_FLOAT: - case AO_SCHEME_STRING: - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: + default: ao_scheme_stack->state = eval_val; break; } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index acc726c8..fe4bc4f5 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -467,6 +467,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_BOOL] = &ao_scheme_bool_type, [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, [AO_SCHEME_FLOAT] = &ao_scheme_float_type, + [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index d726321c..553585db 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -68,6 +68,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, + [AO_SCHEME_VECTOR] = { + .write = ao_scheme_vector_write, + .display = ao_scheme_vector_display + }, }; static const struct ao_scheme_funcs * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 30e29441..9ed54b9f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -340,6 +340,8 @@ _lex(void) add_token(c); end_token(); return BOOL; + case '(': + return OPEN_VECTOR; case '\\': for (;;) { int alphabetic; @@ -474,10 +476,12 @@ int ao_scheme_read_list; struct ao_scheme_cons *ao_scheme_read_cons; struct ao_scheme_cons *ao_scheme_read_cons_tail; struct ao_scheme_cons *ao_scheme_read_stack; +static int ao_scheme_read_state; #define READ_IN_QUOTE 0x01 #define READ_SAW_DOT 0x02 #define READ_DONE_DOT 0x04 +#define READ_SAW_VECTOR 0x08 static int push_read_stack(int read_state) @@ -490,7 +494,8 @@ push_read_stack(int read_state) ao_scheme_cons_poly(ao_scheme_read_stack))); if (!ao_scheme_read_stack) return 0; - } + } else + ao_scheme_read_state = read_state; ao_scheme_read_cons = NULL; ao_scheme_read_cons_tail = NULL; return 1; @@ -513,6 +518,7 @@ pop_read_stack(void) ao_scheme_read_cons = 0; ao_scheme_read_cons_tail = 0; ao_scheme_read_stack = 0; + read_state = ao_scheme_read_state; } RDBG_OUT(); RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); @@ -532,7 +538,9 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN) { + while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + if (parse_token == OPEN_VECTOR) + read_state |= READ_SAW_VECTOR; if (!push_read_stack(read_state)) return AO_SCHEME_NIL; ao_scheme_read_list++; @@ -604,6 +612,8 @@ ao_scheme_read(void) v = ao_scheme_cons_poly(ao_scheme_read_cons); --ao_scheme_read_list; read_state = pop_read_stack(); + if (read_state & READ_SAW_VECTOR) + v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); break; case DOT: if (!ao_scheme_read_list) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e9508835..e10a7d05 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -32,6 +32,7 @@ # define FLOAT 10 # define DOT 11 # define BOOL 12 +# define OPEN_VECTOR 13 /* * character classes -- cgit v1.2.3 From 7e14e243565e814ddd524c8d09454719dc89c6d8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 13:13:27 -0800 Subject: altos/scheme: Add a bunch of string and vector builtins Just make the language closer to r7rs Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 124 ++++++++++++++++++++++++++++++++++++--- src/scheme/ao_scheme_builtin.txt | 19 +++--- 2 files changed, 128 insertions(+), 15 deletions(-) (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index ae96df7f..397ce032 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -123,10 +123,21 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty ao_poly car = ao_scheme_arg(cons, argc); if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) - return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); return _ao_scheme_bool_true; } +int32_t +ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) +{ + ao_poly p = ao_scheme_arg(cons, argc); + int32_t i = ao_scheme_poly_integer(p); + + if (i == AO_SCHEME_NOT_INTEGER) + (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); + return i; +} + ao_poly ao_scheme_do_car(struct ao_scheme_cons *cons) { @@ -568,6 +579,88 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); } +ao_poly +ao_scheme_do_string_ref(struct ao_scheme_cons *cons) +{ + char *string; + int32_t ref; + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); + if (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + while (*string && ref) { + ++string; + --ref; + } + if (!*string) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", + _ao_scheme_atom_string2dref, + ao_scheme_arg(cons, 0), + ao_scheme_arg(cons, 1)); + return ao_scheme_int_poly(*string); +} + +ao_poly +ao_scheme_do_string_length(struct ao_scheme_cons *cons) +{ + char *string; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + return ao_scheme_integer_poly(strlen(string)); +} + +ao_poly +ao_scheme_do_string_copy(struct ao_scheme_cons *cons) +{ + char *string; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + return ao_scheme_string_poly(ao_scheme_string_copy(string)); +} + +ao_poly +ao_scheme_do_string_set(struct ao_scheme_cons *cons) +{ + char *string; + int32_t ref; + int32_t val; + + if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3)) + return AO_SCHEME_NIL; + if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); + if (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); + if (val == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + while (*string && ref) { + ++string; + --ref; + } + if (!*string) + return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", + _ao_scheme_atom_string2dset21, + ao_scheme_arg(cons, 0), + ao_scheme_arg(cons, 1)); + *string = val; + return ao_scheme_int_poly(*string); +} + ao_poly ao_scheme_do_flush_output(struct ao_scheme_cons *cons) { @@ -580,10 +673,11 @@ ao_scheme_do_flush_output(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_led(struct ao_scheme_cons *cons) { - ao_poly led; + int32_t led; if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); + if (led == AO_SCHEME_NOT_INTEGER) return AO_SCHEME_NIL; led = ao_scheme_arg(cons, 0); ao_scheme_os_led(ao_scheme_poly_int(led)); @@ -593,13 +687,14 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_delay(struct ao_scheme_cons *cons) { - ao_poly delay; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + int32_t delay; + + if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); + if (delay == AO_SCHEME_NOT_INTEGER) return AO_SCHEME_NIL; - delay = ao_scheme_arg(cons, 0); - ao_scheme_os_delay(ao_scheme_poly_int(delay)); + ao_scheme_os_delay(delay); return delay; } @@ -869,6 +964,19 @@ ao_scheme_do_vector(struct ao_scheme_cons *cons) return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); } +ao_poly +ao_scheme_do_make_vector(struct ao_scheme_cons *cons) +{ + int32_t k; + + if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) + return AO_SCHEME_NIL; + k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); + if (k == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); +} + ao_poly ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index e7b3d75c..b7261ce1 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -20,7 +20,7 @@ nlambda begin nlambda while f_lambda write f_lambda display -f_lambda plus + +f_lambda plus + string-append f_lambda minus - f_lambda times * f_lambda divide / @@ -28,12 +28,10 @@ f_lambda modulo modulo % f_lambda remainder f_lambda quotient f_lambda equal = eq? eqv? -f_lambda less < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list +f_lambda less < string string>? +f_lambda less_equal <= string<=? +f_lambda greater_equal >= string>=? f_lambda flush_output flush-output f_lambda delay f_lambda led @@ -51,9 +49,15 @@ f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! f_lambda symbolp symbol? +f_lambda list_to_string list->string +f_lambda string_to_list string->list f_lambda symbol_to_string symbol->string f_lambda string_to_symbol string->symbol f_lambda stringp string? +f_lambda string_ref string-ref +f_lambda string_set string-set! +f_lambda string_copy string-copy +f_lambda string_length string-length f_lambda procedurep procedure? lambda apply f_lambda read_char read-char @@ -69,6 +73,7 @@ f_lambda sqrt f_lambda vector_ref vector-ref f_lambda vector_set vector-set! f_lambda vector +f_lambda make_vector make-vector f_lambda list_to_vector list->vector f_lambda vector_to_list vector->list f_lambda vector_length vector-length -- 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_builtin.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 From bdafb4dfad89d92efec37ed826d5f22e9167e717 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:52:26 -0800 Subject: altos/scheme: Stash cons across value allocation in compare Large ints, strings and floats can cause allocation, requiring that the 'cons' pointer be stashed and retrieved in case it moved. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 6f9e1390..7a590735 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -319,6 +319,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) if (cons == orig_cons) { ret = car; + ao_scheme_cons_stash(0, cons); if (cons->cdr == AO_SCHEME_NIL) { switch (op) { case builtin_minus: @@ -339,6 +340,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) break; } } + cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { int32_t r = ao_scheme_poly_integer(ret); int32_t c = ao_scheme_poly_integer(car); @@ -390,7 +392,9 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } + ao_scheme_cons_stash(0, cons); ret = ao_scheme_integer_poly(r); + cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; inexact: @@ -416,12 +420,18 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } + ao_scheme_cons_stash(0, cons); ret = ao_scheme_float_get(r); + cons = ao_scheme_cons_fetch(0); } - - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { + ao_scheme_cons_stash(0, cons); ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), - ao_scheme_poly_string(car))); + ao_scheme_poly_string(car))); + cons = ao_scheme_cons_fetch(0); + if (!ret) + return ret; + } else return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); } -- cgit v1.2.3 From 3e7a703bb2e70a0568b44159b993386f7ec46e04 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:53:25 -0800 Subject: altos/scheme: Make eqv? work for numbers and strings Large numbers, floats and strings need a value check, not just a comparison between ao_polys Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 44 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 4 deletions(-) (limited to 'src/scheme/ao_scheme_builtin.c') diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 7a590735..1754e677 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -492,9 +492,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { ao_poly right = cons->car; - if (op == builtin_equal) { - if (left != right) - return _ao_scheme_bool_false; + if (op == builtin_equal && left == right) { + ; } else { uint8_t lt = ao_scheme_poly_type(left); uint8_t rt = ao_scheme_poly_type(right); @@ -519,6 +518,38 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) if (!(l >= r)) return _ao_scheme_bool_false; break; + case builtin_equal: + if (!(l == r)) + return _ao_scheme_bool_false; + default: + break; + } + } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { + float l, r; + + l = ao_scheme_poly_number(left); + r = ao_scheme_poly_number(right); + + switch (op) { + case builtin_less: + if (!(l < r)) + return _ao_scheme_bool_false; + break; + case builtin_greater: + if (!(l > r)) + return _ao_scheme_bool_false; + break; + case builtin_less_equal: + if (!(l <= r)) + return _ao_scheme_bool_false; + break; + case builtin_greater_equal: + if (!(l >= r)) + return _ao_scheme_bool_false; + break; + case builtin_equal: + if (!(l == r)) + return _ao_scheme_bool_false; default: break; } @@ -542,10 +573,15 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) if (!(c >= 0)) return _ao_scheme_bool_false; break; + case builtin_equal: + if (!(c == 0)) + return _ao_scheme_bool_false; + break; default: break; } - } + } else + return _ao_scheme_bool_false; } left = right; } -- cgit v1.2.3