commit a8a4efd859c695728bbafbd0103465ca13c1866b
parent 3f2fa9e4054490a6f220dff4a599a25c509a1512
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 25 Nov 2011 13:51:22 -0300
Added reverse to the ground environment, added tests for make-list, list-copy and reverse.
Diffstat:
3 files changed, 131 insertions(+), 59 deletions(-)
diff --git a/TODO b/TODO
@@ -30,7 +30,6 @@
** $named-let (r7rs)
** $do (r7rs)
* applicatives:
-** reverse (r7rs)
** list-set! (r7rs)
** vector-map (r7rs)
** bytevector-map (r7rs)
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -60,56 +60,6 @@ void list(klisp_State *K)
kapply_cc(K, ptree);
}
-/* 5.2.? make-list */
-void make_list(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
-
- UNUSED(xparams);
- UNUSED(denv);
-
- bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill);
-
- if (!get_opt_tpar(K, fill, "any", anytype))
- fill = KINERT;
-
- if (knegativep(tv_s)) {
- klispE_throw_simple(K, "negative list length");
- return;
- } else if (!ttisfixint(tv_s)) {
- klispE_throw_simple(K, "list length is too big");
- return;
- }
- TValue tail = KNIL;
- int i = ivalue(tv_s);
- krooted_vars_push(K, &tail);
- while(i-- > 0) {
- tail = kcons(K, fill, tail);
- }
- krooted_vars_pop(K);
-
- kapply_cc(K, tail);
-}
-
-/* 5.2.? list-copy */
-void list_copy(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
-
- UNUSED(xparams);
- UNUSED(denv);
-
- bind_1p(K, ptree, ls);
- TValue copy = check_copy_list(K, "list-copy", ls, true);
- kapply_cc(K, copy);
-}
-
/* 5.2.2 list* */
void listS(klisp_State *K)
{
@@ -203,6 +153,89 @@ void c_ad_r(klisp_State *K)
kapply_cc(K, obj);
}
+/* 5.4.? make-list */
+void make_list(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill);
+
+ if (!get_opt_tpar(K, fill, "any", anytype))
+ fill = KINERT;
+
+ if (knegativep(tv_s)) {
+ klispE_throw_simple(K, "negative list length");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "list length is too big");
+ return;
+ }
+ TValue tail = KNIL;
+ int i = ivalue(tv_s);
+ krooted_vars_push(K, &tail);
+ while(i-- > 0) {
+ tail = kcons(K, fill, tail);
+ }
+ krooted_vars_pop(K);
+
+ kapply_cc(K, tail);
+}
+
+/* 5.4.? list-copy */
+void list_copy(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1p(K, ptree, ls);
+ TValue copy = check_copy_list(K, "list-copy", ls, true);
+ kapply_cc(K, copy);
+}
+
+/* 5.4.? reverse */
+void reverse(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1p(K, ptree, ls);
+ TValue tail = ls;
+ TValue res = KNIL;
+ krooted_vars_push(K, &res);
+ while(ttispair(tail) && !kis_marked(tail)) {
+ kmark(tail);
+ res = kcons(K, kcar(tail), res);
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ls);
+ krooted_vars_pop(K);
+
+ if (ttispair(tail)) {
+ klispE_throw_simple(K, "expected acyclic list");
+ } else if (!ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ } else {
+ kapply_cc(K, res);
+ }
+}
+
+
/* also used in list-tail and list-ref when receiving
bigint indexes */
void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
@@ -1218,6 +1251,8 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
add_applicative(K, ground_env, "make-list", make_list, 0);
/* 5.?.? list-copy */
add_applicative(K, ground_env, "list-copy", list_copy, 0);
+ /* 5.?.? reverse */
+ add_applicative(K, ground_env, "reverse", reverse, 0);
/* 5.7.1 get-list-metrics */
add_applicative(K, ground_env, "get-list-metrics", get_list_metrics, 0);
/* 5.7.2 list-tail */
diff --git a/src/tests/pairs-and-lists.k b/src/tests/pairs-and-lists.k
@@ -31,11 +31,11 @@
(enc #inert))))
($check-not-predicate (null? (memoize #inert)))
($check-not-predicate (null? 1))
-;($check-not-predicate (null? 1.0))
+($check-not-predicate (null? 1.0))
($check-not-predicate (null? #e+infinity))
-;($check-not-predicate (null? #i+infinity))
-;($check-not-predicate (null? #undefined))
-;($check-not-predicate (null? #real-with-no-primary-value))
+($check-not-predicate (null? #i+infinity))
+($check-not-predicate (null? #undefined))
+($check-not-predicate (null? #real))
($check-not-predicate (null? "string"))
($check-not-predicate (null? #\a))
($check-not-predicate (null? (get-current-input-port)))
@@ -54,11 +54,11 @@
(enc #inert))))
($check-not-predicate (pair? (memoize #inert)))
($check-not-predicate (pair? 1))
-;($check-not-predicate (pair? 1.0))
+($check-not-predicate (pair? 1.0))
($check-not-predicate (pair? #e+infinity))
-;($check-not-predicate (pair? #i+infinity))
-;($check-not-predicate (pair? #undefined))
-;($check-not-predicate (pair? #real-with-no-primary-value))
+($check-not-predicate (pair? #i+infinity))
+($check-not-predicate (pair? #undefined))
+($check-not-predicate (pair? #real))
($check-not-predicate (pair? "string"))
($check-not-predicate (pair? #\a))
($check-not-predicate (pair? (get-current-input-port)))
@@ -128,6 +128,26 @@
($check eq? (cadddr tree16) 15)
($check eq? (cddddr tree16) 16))
+;; make-list
+($check-predicate (null? (make-list 0)))
+($check-predicate (mutable-pair? (make-list 1)))
+($check equal? (make-list 2) (list #inert #inert))
+($check equal? (make-list 3 "val") (list "val" "val" "val"))
+
+;; list-copy
+($check-predicate (null? (list-copy ())))
+($check-predicate (mutable-pair? (list-copy (list 1))))
+($check-predicate (mutable-pair? (list-copy (copy-es-immutable (list 1)))))
+($check equal? (list-copy (list 1 2 3)) (list 1 2 3))
+($check equal? (list-copy (list . #1=(1 2 . #1#))) (list . #2=(1 2 . #2#)))
+
+;; reverse
+($check-predicate (null? (reverse ())))
+($check-predicate (mutable-pair? (reverse (list 1))))
+($check-predicate (mutable-pair? (reverse (copy-es-immutable (list 1)))))
+($check equal? (reverse (list 1)) (list 1))
+($check equal? (reverse (list 1 2 3)) (list 3 2 1))
+
;; get-list-metrics
($check equal? (get-list-metrics ()) (list 0 1 0 0))
($check equal? (get-list-metrics #inert) (list 0 0 0 0))
@@ -353,6 +373,24 @@
($check-error (cadddr tree8))
($check-error (cddddr tree8)))
+;; make-list
+($check-error (make-list))
+($check-error (make-list "str"))
+($check-error (make-list 1 "str" "str2"))
+
+;; list-copy
+($check-error (list-copy))
+($check-error (list-copy () ()))
+($check-error (list-copy #inert))
+($check-error (list-copy (list* 1 2 3)))
+
+;; reverse
+($check-error (reverse))
+($check-error (reverse () ()))
+($check-error (reverse #inert))
+($check-error (reverse (list* 1 2 3)))
+($check-error (reverse (list 1 . #1=(2 . #1#))))
+
;; get-list-metrics
($check-error (get-list-metrics))
($check-error (get-list-metrics () ()))
