From 7e14e243565e814ddd524c8d09454719dc89c6d8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 13:13:27 -0800 Subject: [PATCH] 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(-) 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 -- 2.30.2