summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/scheme/ao_scheme.h5
-rw-r--r--src/scheme/ao_scheme_builtin.c30
-rw-r--r--src/scheme/ao_scheme_builtin.txt1
-rw-r--r--src/scheme/ao_scheme_string.c38
4 files changed, 65 insertions, 9 deletions
diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h
index 34fb2e88..68803462 100644
--- a/src/scheme/ao_scheme.h
+++ b/src/scheme/ao_scheme.h
@@ -710,7 +710,10 @@ struct ao_scheme_string *
ao_scheme_string_copy(struct ao_scheme_string *a);
struct ao_scheme_string *
-ao_scheme_string_make(char *a);
+ao_scheme_string_new(char *a);
+
+struct ao_scheme_string *
+ao_scheme_make_string(int32_t len, char fill);
struct ao_scheme_string *
ao_scheme_atom_to_string(struct ao_scheme_atom *a);
diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c
index 0da68778..0b84a89a 100644
--- a/src/scheme/ao_scheme_builtin.c
+++ b/src/scheme/ao_scheme_builtin.c
@@ -762,17 +762,39 @@ ao_scheme_do_string_set(struct ao_scheme_cons *cons)
val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2);
if (ao_scheme_exception)
return AO_SCHEME_NIL;
+ if (!val)
+ goto fail;
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));
+ goto fail;
*string = val;
return ao_scheme_int_poly(*string);
+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;
+ char fill;
+
+ if (!ao_scheme_check_argc(_ao_scheme_atom_make2dstring, cons, 1, 2))
+ return AO_SCHEME_NIL;
+ len = ao_scheme_arg_int(_ao_scheme_atom_make2dstring, cons, 0);
+ if (ao_scheme_exception)
+ return AO_SCHEME_NIL;
+ fill = ao_scheme_opt_arg_int(_ao_scheme_atom_make2dstring, cons, 1, ' ');
+ if (ao_scheme_exception)
+ return AO_SCHEME_NIL;
+ return ao_scheme_string_poly(ao_scheme_make_string(len, fill));
}
ao_poly
diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt
index bdadbd6a..4739f121 100644
--- a/src/scheme/ao_scheme_builtin.txt
+++ b/src/scheme/ao_scheme_builtin.txt
@@ -63,6 +63,7 @@ all f_lambda string_ref string-ref
all f_lambda string_set string-set!
all f_lambda string_copy string-copy
all f_lambda string_length string-length
+all f_lambda make_string make-string
all f_lambda procedurep procedure?
all lambda apply
all f_lambda read_char read-char
diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c
index dfc74966..2c636d7a 100644
--- a/src/scheme/ao_scheme_string.c
+++ b/src/scheme/ao_scheme_string.c
@@ -51,6 +51,7 @@ ao_scheme_string_alloc(int len)
if (!s)
return NULL;
s->type = AO_SCHEME_STRING;
+ s->val[len] = '\0';
return s;
}
@@ -70,7 +71,19 @@ ao_scheme_string_copy(struct ao_scheme_string *a)
}
struct ao_scheme_string *
-ao_scheme_string_make(char *a)
+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)
{
struct ao_scheme_string *r;
@@ -138,7 +151,6 @@ ao_scheme_string_pack(struct ao_scheme_cons *cons)
return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack");
cons = ao_scheme_cons_cdr(cons);
}
- *rval++ = 0;
return ao_scheme_string_poly(r);
}
@@ -183,14 +195,32 @@ ao_scheme_string_write(ao_poly p, bool write)
putchar('"');
while ((c = *sval++)) {
switch (c) {
+ case '\a':
+ printf("\\a");
+ break;
+ case '\b':
+ printf("\\b");
+ break;
+ case '\t':
+ printf ("\\t");
+ break;
case '\n':
printf ("\\n");
break;
case '\r':
printf ("\\r");
break;
- case '\t':
- printf ("\\t");
+ case '\f':
+ printf("\\f");
+ break;
+ case '\v':
+ printf("\\v");
+ break;
+ case '\"':
+ printf("\\\"");
+ break;
+ case '\\':
+ printf("\\\\");
break;
default:
if (c < ' ')