klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
MTODO | 1-
Msrc/kgpairs_lists.c | 135++++++++++++++++++++++++++++++++++++++++++++++++++-----------------------------
Msrc/tests/pairs-and-lists.k | 54++++++++++++++++++++++++++++++++++++++++++++++--------
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 () ()))