commit 9877b1ad617e3fd452f42c2ed1a9bb802e8eed44
parent 6fdc0dabcbb73819675aca0aa530dfd9f03382a5
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 28 Nov 2011 19:05:50 -0300
Added string-for-each, vector-for-each, and bytevector-for-each to the ground environment. Added the corresponding tests.
Diffstat:
| M | TODO | | | 6 | ------ |
| M | src/kgcontrol.c | | | 80 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | src/tests/control.k | | | 168 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- |
3 files changed, 246 insertions(+), 8 deletions(-)
diff --git a/TODO b/TODO
@@ -30,9 +30,6 @@
* operatives:
** $when (r7rs)
** $unless (r7rs)
-** $string-for-each (r7rs)
-** $vector-for-each (r7rs)
-** $bytevector-for-each
** $case (r7rs)
** $case-lambda (r7rs)
** $case-vau (r7rs)
@@ -40,9 +37,6 @@
** $do (r7rs)
** $define-record-type (r7rs)
* applicatives:
-** vector-map (r7rs)
-** bytevector-map (r7rs)
-** string-map (r7rs)
** read-line (r7rs)
** number->string (r7rs)
** string->number (r7rs)
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -368,6 +368,79 @@ void for_each(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* 6.9.? string-for-each, vector-for-each, bytevector-for-each */
+void array_for_each(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ /*
+ ** xparams[1]: array->list fn (with type check and size ret)
+ */
+
+ TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) =
+ pvalue(xparams[0]);
+
+ bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
+
+ /* check that lss is a non empty list, and copy it */
+ if (ttisnil(lss)) {
+ klispE_throw_simple(K, "no arguments after applicative");
+ return;
+ }
+
+ int32_t app_pairs, app_apairs, app_cpairs;
+ /* the copied list should be protected from gc, and will host
+ the lists resulting from the conversion */
+ lss = check_copy_list(K, lss, true, &app_pairs, &app_cpairs);
+ app_apairs = app_pairs - app_cpairs;
+ krooted_tvs_push(K, lss);
+
+ /* check that all elements have the correct type and same size,
+ and convert them to lists */
+ int32_t res_pairs;
+ TValue head = kcar(lss);
+ TValue tail = kcdr(lss);
+ TValue ls = array_to_list(K, head, &res_pairs);
+ kset_car(lss, ls); /* save the first */
+ /* all array will produce acyclic lists */
+ for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) {
+ head = kcar(tail);
+ int32_t pairs;
+ ls = array_to_list(K, head, &pairs);
+ /* in klisp all arrays should have the same length */
+ if (pairs != res_pairs) {
+ klispE_throw_simple(K, "arguments of different length");
+ return;
+ }
+ kset_car(tail, ls);
+ tail = kcdr(tail);
+ }
+
+ /* create the list of parameters to app */
+ lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
+ res_pairs, 0); /* cycle pairs is always 0 */
+
+ /* ASK John: the semantics when this is mixed with continuations,
+ isn't all that great..., but what are the expectations considering
+ there is no prescribed order? */
+
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, lss);
+
+ /* schedule all elements at once, this will also return #inert once
+ done. */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
+ i2tv(res_pairs), denv);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ /* this will be a nop */
+ kapply_cc(K, KINERT);
+}
+
/* init ground */
void kinit_control_ground_env(klisp_State *K)
{
@@ -385,6 +458,13 @@ void kinit_control_ground_env(klisp_State *K)
add_operative(K, ground_env, "$cond", Scond, 0);
/* 6.9.1 for-each */
add_applicative(K, ground_env, "for-each", for_each, 0);
+ /* 6.9.? string-for-each, vector-for-each, bytevector-for-each */
+ add_applicative(K, ground_env, "string-for-each", array_for_each, 1,
+ p2tv(string_to_list_h));
+ add_applicative(K, ground_env, "vector-for-each", array_for_each, 1,
+ p2tv(vector_to_list_h));
+ add_applicative(K, ground_env, "bytevector-for-each", array_for_each, 1,
+ p2tv(bytevector_to_list_h));
}
/* init continuation names */
diff --git a/src/tests/control.k b/src/tests/control.k
@@ -146,6 +146,128 @@
#f))
+;; string-for-each
+($check-predicate (applicative? string-for-each))
+($check eq? (string-for-each char-upcase "abcd") #inert)
+($check eq? (string-for-each char<? "abcd" "efgh") #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (string-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ "a")
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda (x)
+ (set-car! p (+ (car p)
+ (char->integer x))))
+ "abcd")
+ (car p))
+ (apply + (map char->integer (string->list "abcd")))))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda (x y )
+ (set-car! p (+ (car p)
+ (char->integer x)
+ (char->integer y))))
+ "abc"
+ "def")
+ (car p))
+ (apply + (map char->integer (string->list "abcdef")))))
+
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=("abc"
+ "def"
+ . #0#))
+ (car p))
+ #f))
+
+
+;; vector-for-each
+($check-predicate (applicative? vector-for-each))
+($check eq? (vector-for-each + (vector 1 2 3)) #inert)
+($check eq? (vector-for-each <? (vector 1 2) (vector 3 4))
+ #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (vector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (vector 1))
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (vector 1 2 3 4))
+ (car p))
+ 10))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (vector 1 2 3 4)
+ (vector 10 20 30 40))
+ (car p))
+ 110))
+
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((vector 1 2)
+ (vector 3 4)
+ . #0#))
+ (car p))
+ #f))
+
+;; bytevector-for-each
+($check-predicate (applicative? bytevector-for-each))
+($check eq? (bytevector-for-each + (bytevector 1 2 3)) #inert)
+($check eq? (bytevector-for-each <? (bytevector 1 2) (bytevector 3 4))
+ #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (bytevector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (bytevector 1))
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (bytevector 1 2 3 4))
+ (car p))
+ 10))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (bytevector 1 2 3 4)
+ (bytevector 10 20 30 40))
+ (car p))
+ 110))
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((bytevector 1 2)
+ (bytevector 3 4)
+ . #0#))
+ (car p))
+ #f))
+
;;;
;;; Error Checking and Robustness
;;;
@@ -185,8 +307,7 @@
;; for-each
($check-error (for-each))
-;; the list can't be empty
-($check-error (for-each list))
+($check-error (for-each list)) ; the list can't be empty
($check-error (for-each list (list 1 2) (list 1 2 3)))
($check-error (for-each list (list . #0=(1 2 . #0#)) (list 1 2 3)))
@@ -197,3 +318,46 @@
($check-error (for-each list (list 1 2) #inert))
($check-error (for-each cons (list 1 2)))
+
+
+;; string-for-each
+($check-error (string-for-each))
+($check-error (string-for-each char-upcase)) ; the list can't be empty
+
+($check-error (string-for-each char<? "ab" "abc"))
+
+($check-error (string-for-each char-upcase #inert))
+($check-error (string-for-each #inert "abc"))
+($check-error (string-for-each (unwrap char-upcase) "abc"))
+
+($check-error (string-for-each char<? "abc" #inert))
+($check-error (string-for-each cons "abc"))
+
+;; vector-for-each
+($check-error (vector-for-each))
+($check-error (vector-for-each char-upcase)) ; the list can't be empty
+
+($check-error (vector-for-each <? (vector 1 2) (vector 1 2 3)))
+
+($check-error (vector-for-each char-upcase #inert))
+($check-error (vector-for-each #inert (vector 1 2)))
+($check-error (vector-for-each (unwrap char-upcase) (vector 1)))
+
+($check-error (vector-for-each <? (vector 1 2) #inert))
+($check-error (vector-for-each cons (vector 1 2 3)))
+
+;; bytevector-for-each
+($check-error (bytevector-for-each))
+($check-error (bytevector-for-each +)) ; the list can't be empty
+
+($check-error (bytevector-for-each <? (bytevector 1 2)
+ (bytevector 1 2 3)))
+
+($check-error (bytevector-for-each + #inert))
+($check-error (bytevector-for-each #inert (bytevector 1 2 3)))
+($check-error (bytevector-for-each (unwrap char-upcase)
+ (bytevector 1 2)))
+
+($check-error (bytevector-for-each <? (bytevector 1 2) #inert))
+($check-error (bytevector-for-each cons
+ (bytevector 1 2 3)))
