X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_vector.c;h=a716ca0c307e30543c70b65e1f151b4085f407c2;hb=283553f0f118cef1dbcfbf5e86a43575a610d27f;hp=a4127f64d8b43635c86b423d5291cc1429e128c1;hpb=32f6877288ea6b7eb1cae9a42fbe8e2c5dbb2f08;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c
index a4127f64..a716ca0c 100644
--- a/src/scheme/ao_scheme_vector.c
+++ b/src/scheme/ao_scheme_vector.c
@@ -72,74 +72,57 @@ ao_scheme_vector_alloc(uint16_t length, ao_poly fill)
 	return vector;
 }
 
-void
-ao_scheme_vector_write(ao_poly v)
-{
-	struct ao_scheme_vector	*vector = ao_scheme_poly_vector(v);
-	unsigned int i;
+struct vl {
+	struct ao_scheme_vector	*vector;
+	struct vl *prev;
+};
 
-	printf("#(");
-	for (i = 0; i < vector->length; i++) {
-		if (i != 0)
-			printf(" ");
-		if (vector->vals[i] == v)
-			printf ("...");
-		else
-			ao_scheme_poly_write(vector->vals[i]);
-	}
-	printf(")");
-}
+static struct vl *vl;
+static unsigned int vd;
 
 void
-ao_scheme_vector_display(ao_poly v)
-{
-	struct ao_scheme_vector *vector = ao_scheme_poly_vector(v);
-	unsigned int i;
-
-	for (i = 0; i < vector->length; i++) {
-		if (vector->vals[i] == v)
-			printf("...");
-		else
-			ao_scheme_poly_display(vector->vals[i]);
-	}
-}
-
-static int32_t
-ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i)
-{
-	bool	fail;
-	int32_t	offset = ao_scheme_poly_integer(i, &fail);
-
-	if (fail)
-		ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i);
-	if (offset < 0 || vector->length <= offset) {
-		ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)",
-				i, vector->length);
-		offset = -1;
-	}
-	return offset;
-}
-
-ao_poly
-ao_scheme_vector_get(ao_poly v, ao_poly i)
+ao_scheme_vector_write(FILE *out, ao_poly v, bool write)
 {
 	struct ao_scheme_vector	*vector = ao_scheme_poly_vector(v);
-	int32_t			offset = ao_scheme_vector_offset(vector, i);
+	unsigned int i, j;
+	int was_marked = 0;
+	struct vl *ve;
 
-	if (offset < 0)
-		return AO_SCHEME_NIL;
-	return vector->vals[offset];
-}
+	++vd;
+	for (ve = vl; ve; ve = ve->prev)
+		if (ve->vector == vector)
+			abort();
 
-ao_poly
-ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p)
-{
-	struct ao_scheme_vector	*vector = ao_scheme_poly_vector(v);
-	int32_t			offset = ao_scheme_vector_offset(vector, i);
+	ve = malloc(sizeof (struct vl));
+	ve->prev = vl;
+	ve->vector = vector;
+	vl = ve;
 
-	if (offset < 0)
-		return AO_SCHEME_NIL;
-	return vector->vals[offset] = p;
+	ao_scheme_print_start();
+	was_marked = ao_scheme_print_mark_addr(vector);
+	if (was_marked) {
+		fputs("...", out);
+	} else {
+		fputs("#(\n", out);
+		for (i = 0; i < vector->length; i++) {
+			printf("%3d: ", i);
+			for (j = 0; j < vd; j++)
+				printf(".");
+			ao_scheme_poly_write(out, vector->vals[i], write);
+			printf("\n");
+		}
+		printf("     ");
+		for (j = 0; j < vd; j++)
+			printf(".");
+		printf(")");
+	}
+	if (ao_scheme_print_stop() && !was_marked)
+		ao_scheme_print_clear_addr(vector);
+	if (vl != ve)
+		abort();
+	vl = ve->prev;
+	free(ve);
+	--vd;
 }
 
 struct ao_scheme_vector *
@@ -153,9 +136,9 @@ ao_scheme_list_to_vector(struct ao_scheme_cons *cons)
 	if (ao_scheme_exception)
 		return NULL;
 
-	ao_scheme_cons_stash(0, cons);
+	ao_scheme_cons_stash(cons);
 	vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL);
-	cons = ao_scheme_cons_fetch(0);
+	cons = ao_scheme_cons_fetch();
 	if (!vector)
 		return NULL;
 	i = 0;
@@ -167,20 +150,140 @@ 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;) {
-		ao_scheme_poly_stash(2, ao_scheme_vector_poly(vector));
+	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_poly_vector(ao_scheme_poly_fetch(2));
+		vector = ao_scheme_vector_fetch();
 		if (!cons)
 			return NULL;
 	}
 	return cons;
 }
 
+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_make_vector(struct ao_scheme_cons *cons)
+{
+	int32_t	len;
+	ao_poly	val;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_make2dvector, cons,
+				  AO_SCHEME_INT, &len,
+				  AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_false, &val,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_vector_poly(ao_scheme_vector_alloc(len, val));
+}
+
+static bool
+ao_scheme_check_vector(ao_poly proc, struct ao_scheme_vector *vector, int32_t offset)
+{
+	if (offset < 0 || vector->length <= offset) {
+		(void) ao_scheme_error(AO_SCHEME_INVALID, "%v: vector index %d out of range (max %d)",
+				       proc,
+				       offset, vector->length);
+		return false;
+	}
+	return true;
+}
+
+ao_poly
+ao_scheme_do_vector_ref(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_vector	*vector;
+	int32_t			offset;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dref, cons,
+				  AO_SCHEME_VECTOR, &vector,
+				  AO_SCHEME_INT, &offset,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dref, vector, offset))
+		return AO_SCHEME_NIL;
+	return vector->vals[offset];
+}
+
+ao_poly
+ao_scheme_do_vector_set(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_vector	*vector;
+	int32_t			offset;
+	ao_poly			val;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2dset21, cons,
+				  AO_SCHEME_VECTOR, &vector,
+				  AO_SCHEME_INT, &offset,
+				  AO_SCHEME_POLY, &val,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	if (!ao_scheme_check_vector(_ao_scheme_atom_vector2dset21, vector, offset))
+		return AO_SCHEME_NIL;
+	vector->vals[offset] = val;
+	return val;
+}
+
+ao_poly
+ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_cons	*pair;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3evector, cons,
+				  AO_SCHEME_CONS|AO_SCHEME_ARG_NIL_OK, &pair,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_vector_poly(ao_scheme_list_to_vector(pair));
+}
+
+ao_poly
+ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_vector	*vector;
+	int32_t			start, end;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons,
+				  AO_SCHEME_VECTOR, &vector,
+				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(0), &start,
+				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(-1), &end,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	if (end == -1)
+		end = vector->length;
+	return ao_scheme_cons_poly(ao_scheme_vector_to_list(vector, start, end));
+}
+
+ao_poly
+ao_scheme_do_vector_length(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_vector	*vector;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_vector2d3elist, cons,
+				  AO_SCHEME_VECTOR, &vector,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_integer_poly(vector->length);
+}
+
+ao_poly
+ao_scheme_do_vectorp(struct ao_scheme_cons *cons)
+{
+	return ao_scheme_do_typep(_ao_scheme_atom_vector3f, AO_SCHEME_VECTOR, cons);
+}
+
 #endif /* AO_SCHEME_FEATURE_VECTOR */