X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_builtin.c;h=1754e6777790ecd6176c0eb3d9fd067e2ef7be11;hb=40236913922e0395780cd7d90354546ecaf279f9;hp=ae96df7f188690bbd30a6e15ebb1f77e9d09fc97;hpb=d1d98e408311c5ba18138a18f4c88448e4254626;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c
index ae96df7f..1754e677 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)
 {
@@ -186,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)
 {
@@ -295,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:
@@ -315,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);
@@ -366,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:
@@ -392,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");
 	}
@@ -458,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);
@@ -485,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;
 				}
@@ -508,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;
 	}
@@ -568,6 +638,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 +732,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 +746,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 +1023,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)
 {