altos/scheme: Add start/end args to vector->list

This is an r7rs extension which allows you to extract a subset of the
vector.

Signed-off-by: Keith Packard <keithp@keithp.com>

3 files changed, 47 insertions, 13 deletions

diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h
index d4c9bc05..428533b0 100644
--- a/src/scheme/ao_scheme.h
+++ b/src/scheme/ao_scheme.h
@@ -808,7 +808,7 @@ 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);
+ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end);
 
 extern const struct ao_scheme_type	ao_scheme_vector_type;
 
diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c
index e2532c98..0da68778 100644
--- a/src/scheme/ao_scheme_builtin.c
+++ b/src/scheme/ao_scheme_builtin.c
@@ -105,17 +105,23 @@ ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max
 	return _ao_scheme_bool_true;
 }
 
-ao_poly
-ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
+static ao_poly
+ao_scheme_opt_arg(struct ao_scheme_cons *cons, int argc, ao_poly def)
 {
-	if (!cons)
-		return AO_SCHEME_NIL;
-	while (argc--) {
+	for (;;) {
 		if (!cons)
-			return AO_SCHEME_NIL;
+			return def;
+		if (argc == 0)
+			return cons->car;
 		cons = ao_scheme_cons_cdr(cons);
+		argc--;
 	}
-	return cons->car;
+}
+
+ao_poly
+ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
+{
+	return ao_scheme_opt_arg(cons, argc, AO_SCHEME_NIL);
 }
 
 ao_poly
@@ -140,6 +146,18 @@ ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc)
 	return i;
 }
 
+static int32_t
+ao_scheme_opt_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc, int def)
+{
+	ao_poly 	p = ao_scheme_opt_arg(cons, argc, ao_scheme_int_poly(def));
+	bool		fail = false;
+	int32_t		i = ao_scheme_poly_integer(p, &fail);
+
+	if (fail)
+		(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)
 {
@@ -1120,11 +1138,21 @@ ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons)
 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))
+	int	start, end;
+
+	if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 3))
 		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))));
+	start = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 1, ao_scheme_int_poly(0));
+	if (ao_scheme_exception)
+		return AO_SCHEME_NIL;
+	end = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 2, ao_scheme_int_poly(-1));
+	if (ao_scheme_exception)
+		return AO_SCHEME_NIL;
+	return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)),
+							    start,
+							    end));
 }
 
 ao_poly
diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c
index afdc89a8..083823f3 100644
--- a/src/scheme/ao_scheme_vector.c
+++ b/src/scheme/ao_scheme_vector.c
@@ -159,13 +159,19 @@ ao_scheme_list_to_vector(struct ao_scheme_cons *cons)
 }
 
 struct ao_scheme_cons *
-ao_scheme_vector_to_list(struct ao_scheme_vector *vector)
+ao_scheme_vector_to_list(struct ao_scheme_vector *vector, int start, int end)
 {
-	unsigned int		i;
+	int			i;
 	uint16_t		length = vector->length;
 	struct ao_scheme_cons	*cons = NULL;
 
-	for (i = length; i-- > 0;) {
+	if (end == -1)
+		end = length;
+	if (start < 0)
+		start = 0;
+	if (end > length)
+		end = length;
+	for (i = end; i-- > start;) {
 		ao_scheme_vector_stash(vector);
 		cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons));
 		vector = ao_scheme_vector_fetch();