X-Git-Url: https://git.gag.com/?p=fw%2Faltos;a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_string.c;h=c49e1e325c9872a97634614afdf6a6669d8774bc;hp=2c636d7ae49aaba9f518de2f2eca7ecdc8a3d3d4;hb=16061947d4376b41e596d87f97ec53ec29d17644;hpb=39df849f0717d92a7d5bdf8aa5904bd4db1b467f

diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c
index 2c636d7a..c49e1e32 100644
--- a/src/scheme/ao_scheme_string.c
+++ b/src/scheme/ao_scheme_string.c
@@ -55,33 +55,6 @@ ao_scheme_string_alloc(int len)
 	return s;
 }
 
-struct ao_scheme_string *
-ao_scheme_string_copy(struct ao_scheme_string *a)
-{
-	int			alen = strlen(a->val);
-	struct ao_scheme_string	*r;
-
-	ao_scheme_string_stash(a);
-	r = ao_scheme_string_alloc(alen);
-	a = ao_scheme_string_fetch();
-	if (!r)
-		return NULL;
-	strcpy(r->val, a->val);
-	return r;
-}
-
-struct ao_scheme_string *
-ao_scheme_make_string(int32_t len, char fill)
-{
-	struct ao_scheme_string	*r;
-
-	r = ao_scheme_string_alloc(len);
-	if (!r)
-		return NULL;
-	memset(r->val, fill, len);
-	return r;
-}
-
 struct ao_scheme_string *
 ao_scheme_string_new(char *a)
 {
@@ -128,111 +101,247 @@ ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b)
 	return r;
 }
 
-ao_poly
+static ao_poly
 ao_scheme_string_pack(struct ao_scheme_cons *cons)
 {
-	struct ao_scheme_string	*r;
-	char			*rval;
+	struct ao_scheme_string	*string;
+	char			*s;
 	int			len;
 
 	len = ao_scheme_cons_length(cons);
 	ao_scheme_cons_stash(cons);
-	r = ao_scheme_string_alloc(len);
+	string = ao_scheme_string_alloc(len);
 	cons = ao_scheme_cons_fetch();
-	if (!r)
+	if (!string)
 		return AO_SCHEME_NIL;
-	rval = r->val;
+	s = string->val;
 
 	while (cons) {
-		bool fail = false;
 		ao_poly	car = cons->car;
-		*rval++ = ao_scheme_poly_integer(car, &fail);
-		if (fail)
-			return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack");
+		int32_t c;
+		if (!ao_scheme_is_integer(car) || (c = ao_scheme_poly_integer(car)) == 0)
+			return ao_scheme_error(AO_SCHEME_INVALID, "%v: Invalid %v", _ao_scheme_atom_list2d3estring, car);
+		*s++ = c;
 		cons = ao_scheme_cons_cdr(cons);
 	}
-	return ao_scheme_string_poly(r);
+	return ao_scheme_string_poly(string);
 }
 
-ao_poly
+static ao_poly
 ao_scheme_string_unpack(struct ao_scheme_string *a)
 {
-	struct ao_scheme_cons	*cons = NULL, *tail = NULL;
-	int			c;
-	int			i;
+	ao_poly	cons = AO_SCHEME_NIL;
+	int	i;
 
-	for (i = 0; (c = a->val[i]); i++) {
-		struct ao_scheme_cons	*n;
-		ao_scheme_cons_stash(cons);
-		ao_scheme_cons_stash(tail);
+	for (i = strlen(a->val); --i >= 0;) {
 		ao_scheme_string_stash(a);
-		n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL);
+		cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons);
 		a = ao_scheme_string_fetch();
-		tail = ao_scheme_cons_fetch();
-		cons = ao_scheme_cons_fetch();
-
-		if (!n) {
-			cons = NULL;
+		if (!cons)
 			break;
-		}
-		if (tail)
-			tail->cdr = ao_scheme_cons_poly(n);
-		else
-			cons = n;
-		tail = n;
 	}
-	return ao_scheme_cons_poly(cons);
+	return cons;
 }
 
 void
-ao_scheme_string_write(ao_poly p, bool write)
+ao_scheme_string_write(FILE *out, ao_poly p, bool write)
 {
 	struct ao_scheme_string	*s = ao_scheme_poly_string(p);
 	char			*sval = s->val;
 	char			c;
 
 	if (write) {
-		putchar('"');
+		putc('"', out);
 		while ((c = *sval++)) {
 			switch (c) {
 			case '\a':
-				printf("\\a");
+				fputs("\\a", out);
 				break;
 			case '\b':
-				printf("\\b");
+				fputs("\\b", out);
 				break;
 			case '\t':
-				printf ("\\t");
+				fputs("\\t", out);
 				break;
 			case '\n':
-				printf ("\\n");
+				fputs("\\n", out);
 				break;
 			case '\r':
-				printf ("\\r");
+				fputs("\\r", out);
 				break;
 			case '\f':
-				printf("\\f");
+				fputs("\\f", out);
 				break;
 			case '\v':
-				printf("\\v");
+				fputs("\\v", out);
 				break;
 			case '\"':
-				printf("\\\"");
+				fputs("\\\"", out);
 				break;
 			case '\\':
-				printf("\\\\");
+				fputs("\\\\", out);
 				break;
 			default:
 				if (c < ' ')
-					printf("\\%03o", c);
+					fprintf(out, "\\%03o", c);
 				else
-					putchar(c);
+					putc(c, out);
 				break;
 			}
 		}
-		putchar('"');
+		putc('"', out);
 	} else {
 		while ((c = *sval++))
-			putchar(c);
+			putc(c, out);
 	}
 }
+
+ao_poly
+ao_scheme_do_stringp(struct ao_scheme_cons *cons)
+{
+	return ao_scheme_do_typep(_ao_scheme_atom_string3f, AO_SCHEME_STRING, cons);
+}
+
+ao_poly
+ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_cons	*list;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_list2d3estring, cons,
+				  AO_SCHEME_CONS, &list,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_string_pack(list);
+}
+
+ao_poly
+ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_string	*string;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3elist, cons,
+				  AO_SCHEME_STRING, &string,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_string_unpack(string);
+}
+
+static char *
+ao_scheme_string_ref(struct ao_scheme_string *string, int32_t r)
+{
+	char *s = string->val;
+	while (*s && r) {
+		++s;
+		--r;
+	}
+	return s;
+}
+
+ao_poly
+ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_string	*string;
+	int32_t			ref;
+	char			*s;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dref, cons,
+				  AO_SCHEME_STRING, &string,
+				  AO_SCHEME_INT, &ref,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+
+	s = ao_scheme_string_ref(string, ref);
+	if (!*s)
+		return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
+				       _ao_scheme_atom_string2dref,
+				       cons->car,
+				       ao_scheme_arg(cons, 1));
+	return ao_scheme_integer_poly(*s);
+}
+
+ao_poly
+ao_scheme_do_string_length(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_string *string;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dlength, cons,
+				  AO_SCHEME_STRING, &string,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_integer_poly(strlen(string->val));
+}
+
+ao_poly
+ao_scheme_do_string_set(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_string	*string;
+	int32_t			ref;
+	int32_t			val;
+	char			*s;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_string2dset21, cons,
+				  AO_SCHEME_STRING, &string,
+				  AO_SCHEME_INT, &ref,
+				  AO_SCHEME_INT, &val,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	if (!val)
+		goto fail;
+	s = ao_scheme_string_ref(string, ref);
+	if (!*s)
+		goto fail;
+	*s = val;
+	return ao_scheme_integer_poly(val);
+fail:
+	return ao_scheme_error(AO_SCHEME_INVALID, "%v: %v[%v] = %v invalid",
+			       _ao_scheme_atom_string2dset21,
+			       ao_scheme_arg(cons, 0),
+			       ao_scheme_arg(cons, 1),
+			       ao_scheme_arg(cons, 2));
+}
+
+ao_poly
+ao_scheme_do_make_string(struct ao_scheme_cons *cons)
+{
+	int32_t			len;
+	int32_t			fill;
+	struct ao_scheme_string	*string;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_make2dstring, cons,
+				  AO_SCHEME_INT, &len,
+				  AO_SCHEME_INT|AO_SCHEME_ARG_OPTIONAL, ao_scheme_int_poly(' '), &fill,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	if (!fill)
+		return ao_scheme_error(AO_SCHEME_INVALID, "%v: fill 0 invalid",
+				       _ao_scheme_atom_make2dstring);
+	string = ao_scheme_string_alloc(len);
+	if (!string)
+		return AO_SCHEME_NIL;
+	memset(string->val, fill, len);
+	return ao_scheme_string_poly(string);
+}
+
+ao_poly
+ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_atom	*atom;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_symbol2d3estring, cons,
+				  AO_SCHEME_ATOM, &atom,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_string_poly(ao_scheme_atom_to_string(atom));
+}
+
+ao_poly
+ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
+{
+	struct ao_scheme_string	*string;
+
+	if (!ao_scheme_parse_args(_ao_scheme_atom_string2d3esymbol, cons,
+				  AO_SCHEME_STRING, &string,
+				  AO_SCHEME_ARG_END))
+		return AO_SCHEME_NIL;
+	return ao_scheme_atom_poly(ao_scheme_string_to_atom(string));
+}