altos/scheme: add list-copy

A lot easier as a built-in; the obvious scheme version is recursive.

Signed-off-by: Keith Packard <keithp@keithp.com>

diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h
index 4655b2a988c564ef97d011b3ac61da36c1a74c6e..2fa1ed60e52b0907f9e49770261df64d0745c589 100644 (file)
--- a/src/scheme/ao_scheme.h
+++ b/src/scheme/ao_scheme.h
@@ -634,6 +634,9 @@ ao_scheme_cons_display(ao_poly);
 int
 ao_scheme_cons_length(struct ao_scheme_cons *cons);
 
+struct ao_scheme_cons *
+ao_scheme_cons_copy(struct ao_scheme_cons *cons);
+
 /* string */
 extern const struct ao_scheme_type ao_scheme_string_type;
 

diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c
index 397ce0329e3e1348fd45ac8e68518da31c4d202d..6f9e1390c9eb6e090bb74d40872aba5439f91709 100644 (file)
--- a/src/scheme/ao_scheme_builtin.c
+++ b/src/scheme/ao_scheme_builtin.c
@@ -197,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)
 {

diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt
index b7261ce14359f5e2720375956ba58244c15def56..17f5ea0c275e770b78cdb7bccb6c09e1776a8a9e 100644 (file)
--- a/src/scheme/ao_scheme_builtin.txt
+++ b/src/scheme/ao_scheme_builtin.txt
@@ -8,6 +8,7 @@ f_lambda        cdr
 f_lambda       cons
 f_lambda       last
 f_lambda       length
+f_lambda       list_copy       list-copy
 nlambda                quote
 atom           quasiquote
 atom           unquote

diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c
index 21ee10cc668abb405ea52db60204053e5a6f01f1..02512e15f895ab36aa46a2dbf1ccb9aa56df4d7f 100644 (file)
--- a/src/scheme/ao_scheme_cons.c
+++ b/src/scheme/ao_scheme_cons.c
@@ -112,7 +112,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons)
        if (cdr == AO_SCHEME_NIL)
                return NULL;
        if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) {
-               (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list");
+               (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr);
                return NULL;
        }
        return ao_scheme_poly_cons(cdr);
@@ -124,6 +124,42 @@ ao_scheme__cons(ao_poly car, ao_poly cdr)
        return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr));
 }
 
+struct ao_scheme_cons *
+ao_scheme_cons_copy(struct ao_scheme_cons *cons)
+{
+       struct ao_scheme_cons   *head = NULL;
+       struct ao_scheme_cons   *tail = NULL;
+
+       while (cons) {
+               struct ao_scheme_cons   *new;
+               ao_poly cdr;
+
+               ao_scheme_cons_stash(0, cons);
+               ao_scheme_cons_stash(1, head);
+               ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail));
+               new = ao_scheme_alloc(sizeof (struct ao_scheme_cons));
+               cons = ao_scheme_cons_fetch(0);
+               head = ao_scheme_cons_fetch(1);
+               tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0));
+               if (!new)
+                       return AO_SCHEME_NIL;
+               new->car = cons->car;
+               new->cdr = AO_SCHEME_NIL;
+               if (!head)
+                       head = new;
+               else
+                       tail->cdr = ao_scheme_cons_poly(new);
+               tail = new;
+               cdr = cons->cdr;
+               if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) {
+                       tail->cdr = cdr;
+                       break;
+               }
+               cons = ao_scheme_poly_cons(cdr);
+       }
+       return head;
+}
+
 void
 ao_scheme_cons_free(struct ao_scheme_cons *cons)
 {