X-Git-Url: https://git.gag.com/?a=blobdiff_plain;f=src%2Fscheme%2Fao_scheme_string.c;h=2c6d096000d43d759c9d7a276ad5ad1c88dcafcc;hb=4b52fc6eea9a478cb3dd42dcd32c92838df39734;hp=e25306cbea087d6a0964c346266ce552472d0c76;hpb=2f8fce1cf6ce4bd12a836cc8ee15f4edbc95c95e;p=fw%2Faltos

diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c
index e25306cb..2c6d0960 100644
--- a/src/scheme/ao_scheme_string.c
+++ b/src/scheme/ao_scheme_string.c
@@ -24,9 +24,10 @@ static void string_mark(void *addr)
 
 static int string_size(void *addr)
 {
+	struct ao_scheme_string	*string = addr;
 	if (!addr)
 		return 0;
-	return strlen(addr) + 1;
+	return strlen(string->val) + 2;
 }
 
 static void string_move(void *addr)
@@ -41,121 +42,308 @@ const struct ao_scheme_type ao_scheme_string_type = {
 	.name = "string",
 };
 
-char *
-ao_scheme_string_copy(char *a)
+static struct ao_scheme_string *
+ao_scheme_string_alloc(int len)
 {
-	int	alen = strlen(a);
+	struct ao_scheme_string	*s;
 
-	ao_scheme_string_stash(0, a);
-	char	*r = ao_scheme_alloc(alen + 1);
-	a = ao_scheme_string_fetch(0);
+	if (len < 0)
+		return NULL;
+	s = ao_scheme_alloc(len + 2);
+	if (!s)
+		return NULL;
+	s->type = AO_SCHEME_STRING;
+	s->val[len] = '\0';
+	return s;
+}
+
+struct ao_scheme_string *
+ao_scheme_string_new(char *a)
+{
+	struct ao_scheme_string	*r;
+
+	r = ao_scheme_string_alloc(strlen(a));
 	if (!r)
 		return NULL;
-	strcpy(r, a);
+	strcpy(r->val, a);
 	return r;
 }
 
-char *
-ao_scheme_string_cat(char *a, char *b)
+struct ao_scheme_string *
+ao_scheme_atom_to_string(struct ao_scheme_atom *a)
 {
-	int	alen = strlen(a);
-	int	blen = strlen(b);
+	int			alen = strlen(a->name);
+	struct ao_scheme_string	*r;
 
-	ao_scheme_string_stash(0, a);
-	ao_scheme_string_stash(1, b);
-	char	*r = ao_scheme_alloc(alen + blen + 1);
-	a = ao_scheme_string_fetch(0);
-	b = ao_scheme_string_fetch(1);
+	ao_scheme_atom_stash(a);
+	r = ao_scheme_string_alloc(alen);
+	a = ao_scheme_atom_fetch();
 	if (!r)
 		return NULL;
-	strcpy(r, a);
-	strcpy(r+alen, b);
+	strcpy(r->val, a->name);
 	return r;
 }
 
-ao_poly
+struct ao_scheme_string *
+ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b)
+{
+	int				alen = strlen(a->val);
+	int				blen = strlen(b->val);
+	struct ao_scheme_string 	*r;
+
+	ao_scheme_string_stash(a);
+	ao_scheme_string_stash(b);
+	r = ao_scheme_string_alloc(alen + blen);
+	b = ao_scheme_string_fetch();
+	a = ao_scheme_string_fetch();
+	if (!r)
+		return NULL;
+	strcpy(r->val, a->val);
+	strcpy(r->val+alen, b->val);
+	return r;
+}
+
+static ao_poly
 ao_scheme_string_pack(struct ao_scheme_cons *cons)
 {
-	int	len = ao_scheme_cons_length(cons);
-	ao_scheme_cons_stash(0, cons);
-	char	*r = ao_scheme_alloc(len + 1);
-	cons = ao_scheme_cons_fetch(0);
-	char	*s = r;
+	struct ao_scheme_string	*string;
+	char			*s;
+	int			len;
+
+	len = ao_scheme_cons_length(cons);
+	ao_scheme_cons_stash(cons);
+	string = ao_scheme_string_alloc(len);
+	cons = ao_scheme_cons_fetch();
+	if (!string)
+		return AO_SCHEME_NIL;
+	s = string->val;
 
 	while (cons) {
-		if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car)))
-			return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack");
-		*s++ = ao_scheme_poly_integer(cons->car);
-		cons = ao_scheme_poly_cons(cons->cdr);
+		ao_poly	car = cons->car;
+		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);
 	}
-	*s++ = 0;
-	return ao_scheme_string_poly(r);
+	return ao_scheme_string_poly(string);
 }
 
-ao_poly
-ao_scheme_string_unpack(char *a)
-{
-	struct ao_scheme_cons	*cons = NULL, *tail = NULL;
-	int			c;
-	int			i;
-
-	for (i = 0; (c = a[i]); i++) {
-		ao_scheme_cons_stash(0, cons);
-		ao_scheme_cons_stash(1, tail);
-		ao_scheme_string_stash(0, a);
-		struct ao_scheme_cons	*n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL);
-		a = ao_scheme_string_fetch(0);
-		cons = ao_scheme_cons_fetch(0);
-		tail = ao_scheme_cons_fetch(1);
-
-		if (!n) {
-			cons = NULL;
+static ao_poly
+ao_scheme_string_unpack(struct ao_scheme_string *a)
+{
+	ao_poly	cons = AO_SCHEME_NIL;
+	int	i;
+
+	for (i = strlen(a->val); --i >= 0;) {
+		ao_scheme_string_stash(a);
+		cons = ao_scheme_cons(ao_scheme_int_poly(a->val[i]), cons);
+		a = ao_scheme_string_fetch();
+		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)
+ao_scheme_string_write(FILE *out, ao_poly p, bool write)
 {
-	char	*s = ao_scheme_poly_string(p);
-	char	c;
+	struct ao_scheme_string	*s = ao_scheme_poly_string(p);
+	char			*sval = s->val;
+	char			c;
 
-	putchar('"');
-	while ((c = *s++)) {
-		switch (c) {
-		case '\n':
-			printf ("\\n");
-			break;
-		case '\r':
-			printf ("\\r");
-			break;
-		case '\t':
-			printf ("\\t");
-			break;
-		default:
-			if (c < ' ')
-				printf("\\%03o", c);
-			else
-				putchar(c);
-			break;
+	if (write) {
+		putc('"', out);
+		while ((c = *sval++)) {
+			switch (c) {
+			case '\a':
+				fputs("\\a", out);
+				break;
+			case '\b':
+				fputs("\\b", out);
+				break;
+			case '\t':
+				fputs("\\t", out);
+				break;
+			case '\n':
+				fputs("\\n", out);
+				break;
+			case '\r':
+				fputs("\\r", out);
+				break;
+			case '\f':
+				fputs("\\f", out);
+				break;
+			case '\v':
+				fputs("\\v", out);
+				break;
+			case '\"':
+				fputs("\\\"", out);
+				break;
+			case '\\':
+				fputs("\\\\", out);
+				break;
+			default:
+				if ((uint8_t) c < ' ')
+					fprintf(out, "\\%03o", (uint8_t) c);
+				else
+					putc(c, out);
+				break;
+			}
 		}
+		putc('"', out);
+	} else {
+		while ((c = *sval++))
+			putc(c, out);
 	}
-	putchar('"');
 }
 
-void
-ao_scheme_string_display(ao_poly p)
+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)
 {
-	char	*s = ao_scheme_poly_string(p);
-	char	c;
+	struct ao_scheme_string	*string;
 
-	while ((c = *s++))
-		putchar(c);
+	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));
 }