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)
{
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));
+}
projects / fw / altos / blobdiff