commit 2d709d86555c0874c0aea1422b29a0645895f583
parent 408eb9dbbe43962ac70d2c31f5c84be2fd717bb0
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 28 Nov 2011 21:23:30 -0300
Added $when and $unless to the ground environment. Added test for these.
Diffstat:
6 files changed, 208 insertions(+), 13 deletions(-)
diff --git a/TODO b/TODO
@@ -20,14 +20,13 @@
typedef like lua)
* fix:
** fix/test the tty detection in the interpreter
+** fix char-ready? and u8-ready? (r7rs)
* documentation
** fix some inconsistencies between the man page and the interpreter
behaviour.
** update the manual with the current features
** add a section to the manual with the interpreter usage
* operatives:
-** $when (r7rs)
-** $unless (r7rs)
** $case (r7rs)
** $case-lambda (r7rs)
** $case-vau (r7rs)
@@ -35,9 +34,10 @@
** $do (r7rs)
** $define-record-type (r7rs)
* applicatives:
-** read-line (r7rs)
** number->string (r7rs)
** string->number (r7rs)
+** read-line (r7rs)
+** write-simple (r7rs)
* reader
** symbol escapes (r7rs)
** string escapes (r7rs)
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -23,6 +23,7 @@
void do_select_clause(klisp_State *K);
void do_cond(klisp_State *K);
void do_for_each(klisp_State *K);
+void do_Swhen_Sunless(klisp_State *K);
/* 4.5.1 inert? */
/* uses typep */
@@ -36,8 +37,8 @@ void Sif(klisp_State *K)
TValue ptree = K->next_value;
TValue denv = K->next_env;
klisp_assert(ttisenvironment(K->next_env));
- (void) denv;
- (void) xparams;
+ UNUSED(denv);
+ UNUSED(xparams);
bind_3p(K, ptree, test, cons_c, alt_c);
@@ -441,6 +442,105 @@ void array_for_each(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* Helper for $when and $unless */
+void do_Swhen_Sunless(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+
+ /*
+ ** xparams[0]: bool condition
+ ** xparams[1]: body
+ ** xparams[2]: denv
+ ** xparams[3]: si for whole form
+ */
+ bool cond = bvalue(xparams[0]);
+ TValue ls = xparams[1];
+ TValue denv = xparams[2];
+#if KTRACK_SI
+ TValue si = xparams[3];
+#endif
+
+ if (!ttisboolean(obj)) {
+ klispE_throw_simple(K, "test is not a boolean");
+ return;
+ }
+
+ if (bvalue(obj) == cond && !ttisnil(ls)) {
+ /* only contruct the #inert returning continuation if the
+ current continuation is not of the same type */
+ if (!kis_inert_ret_cont(kget_cc(K))) {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_return_value, 1, KINERT);
+ /* mark it, so that it can be detected as inert throwing cont */
+ kset_inert_ret_cont(new_cont);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the whole form */
+ kset_source_info(K, new_cont, si);
+#endif
+ }
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ /* TODO this could be at least in an inlineable function to
+ allow used from $lambda, $vau, $let family, load, etc */
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
+#endif
+ krooted_tvs_pop(K);
+ }
+ ktail_eval(K, kcar(ls), denv);
+ } else {
+ /* either the test failed or the body was nil */
+ kapply_cc(K, KINERT);
+ }
+}
+
+/* ASK JOHN: list is copied here (like in $sequence) */
+void Swhen_Sunless(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ bind_al1p(K, ptree, test, body);
+
+ /*
+ ** xparams[0]: bool condition
+ */
+ TValue tv_cond = xparams[0];
+
+ /* the list of instructions is copied to avoid mutation */
+ /* MAYBE: copy the evaluation structure, ASK John */
+ TValue ls = check_copy_list(K, body, false, NULL, NULL);
+ krooted_tvs_push(K, ls);
+ /* prepare the continuation that will check the test result
+ and do the evaluation */
+ TValue si = K->next_si; /* this is the source info of the whole
+ $when/$unless form */
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_Swhen_Sunless,
+ 4, tv_cond, ls, denv, si);
+ krooted_tvs_pop(K);
+ /*
+ ** Mark as a bool checking cont, not necessary but avoids a continuation
+ ** in the last evaluation in the common use of
+ ** ($when/$unless ($or?/$and? ...) ...)
+ */
+ kset_bool_check_cont(new_cont);
+ kset_cc(K, new_cont);
+ ktail_eval(K, test, denv);
+}
+
/* init ground */
void kinit_control_ground_env(klisp_State *K)
{
@@ -465,6 +565,11 @@ void kinit_control_ground_env(klisp_State *K)
p2tv(vector_to_list_h));
add_applicative(K, ground_env, "bytevector-for-each", array_for_each, 1,
p2tv(bytevector_to_list_h));
+ /* ?.? */
+ add_operative(K, ground_env, "$when", Swhen_Sunless, 1,
+ b2tv(true));
+ add_operative(K, ground_env, "$unless", Swhen_Sunless, 1,
+ b2tv(false));
}
/* init continuation names */
@@ -473,6 +578,8 @@ void kinit_control_cont_names(klisp_State *K)
Table *t = tv2table(K->cont_name_table);
add_cont_name(K, t, do_select_clause, "select-clause");
+ add_cont_name(K, t, do_Swhen_Sunless, "conditional-eval-sequence");
+
add_cont_name(K, t, do_cond, "eval-cond-list");
add_cont_name(K, t, do_for_each, "for-each");
}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -426,12 +426,6 @@ TValue make_bind_continuation(klisp_State *K, TValue key,
TValue check_copy_guards(klisp_State *K, char *name, TValue obj);
void guard_dynamic_extent(klisp_State *K);
-/* GC: assumes parent & obj are rooted */
-inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
-{
- return kmake_continuation(K, parent, do_return_value, 1, obj);
-}
-
/* Some helpers for working with fixints (signed 32 bits) */
inline int32_t kabs32(int32_t a) { return a < 0? -a : a; }
inline int64_t kabs64(int64_t a) { return a < 0? -a : a; }
diff --git a/src/kgports.c b/src/kgports.c
@@ -697,7 +697,9 @@ void load(klisp_State *K)
TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
- TValue inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
+ TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1,
+ KINERT);
+
krooted_tvs_push(K, inert_cont);
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
@@ -760,7 +762,8 @@ void get_module(klisp_State *K)
kadd_binding(K, env, K->module_params_sym, maybe_env);
}
- TValue ret_env_cont = make_return_value_cont(K, kget_cc(K), env);
+ TValue ret_env_cont = kmake_continuation(K, kget_cc(K), do_return_value,
+ 1, env);
krooted_tvs_pop(K); /* env alread in cont */
krooted_tvs_push(K, ret_env_cont);
diff --git a/src/kobject.h b/src/kobject.h
@@ -822,17 +822,22 @@ int32_t kmark_count;
#define K_FLAG_INNER 0x02
#define K_FLAG_DYNAMIC 0x04
#define K_FLAG_BOOL_CHECK 0x08
+/* this is the same as immutable, but there is no problem
+ with continuations */
+#define K_FLAG_INERT_RET 0x10
/* evaluate c_ more than once */
#define kset_inner_cont(c_) (tv_get_kflags(c_) |= K_FLAG_INNER)
#define kset_outer_cont(c_) (tv_get_kflags(c_) |= K_FLAG_OUTER)
#define kset_dyn_cont(c_) (tv_get_kflags(c_) |= K_FLAG_DYNAMIC)
#define kset_bool_check_cont(c_) (tv_get_kflags(c_) |= K_FLAG_BOOL_CHECK)
+#define kset_inert_ret_cont(c_) (tv_get_kflags(c_) |= K_FLAG_INERT_RET)
#define kis_inner_cont(c_) ((tv_get_kflags(c_) & K_FLAG_INNER) != 0)
#define kis_outer_cont(c_) ((tv_get_kflags(c_) & K_FLAG_OUTER) != 0)
#define kis_dyn_cont(c_) ((tv_get_kflags(c_) & K_FLAG_DYNAMIC) != 0)
#define kis_bool_check_cont(c_) ((tv_get_kflags(c_) & K_FLAG_BOOL_CHECK) != 0)
+#define kis_inert_ret_cont(c_) ((tv_get_kflags(c_) & K_FLAG_INERT_RET) != 0)
#define K_FLAG_OUTPUT_PORT 0x01
#define K_FLAG_INPUT_PORT 0x02
diff --git a/src/tests/control.k b/src/tests/control.k
@@ -268,6 +268,76 @@
(car p))
#f))
+;; $when
+($check-predicate (operative? $when))
+($check-predicate (inert? ($when #t)))
+($check-predicate (inert? ($when #f)))
+($check-predicate (inert? ($when #t 1)))
+($check-predicate (inert? ($when #f 1)))
+($check-predicate (inert? ($when #t 1 2)))
+($check-predicate (inert? ($when #f 1 2)))
+
+($let ((p (cons () ())))
+ ($check equal? ($sequence ($when #f (set-car! p 1))
+ (car p))
+ ()))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($when ($sequence
+ (set-car! p (get-current-environment))
+ #f))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($when #t (set-car! p (get-current-environment)))
+ (car p))
+ (get-current-environment)))
+
+;; check tail recursiveness
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($when #t ($let/cc cont1
+ (set-car! p cont1)
+ ($when #t
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
+
+;; $unless
+($check-predicate (operative? $unless))
+($check-predicate (inert? ($unless #t)))
+($check-predicate (inert? ($unless #f)))
+($check-predicate (inert? ($unless #t 1)))
+($check-predicate (inert? ($unless #f 1)))
+($check-predicate (inert? ($unless #t 1 2)))
+($check-predicate (inert? ($unless #f 1 2)))
+
+($let ((p (cons () ())))
+ ($check equal? ($sequence ($unless #t (set-car! p 1))
+ (car p))
+ ()))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($unless ($sequence
+ (set-car! p (get-current-environment))
+ #t))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($unless #f (set-car! p (get-current-environment)))
+ (car p))
+ (get-current-environment)))
+
+;; check tail recursiveness
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($unless #f ($let/cc cont1
+ (set-car! p cont1)
+ ($unless #f
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
+
;;;
;;; Error Checking and Robustness
;;;
@@ -361,3 +431,19 @@
($check-error (bytevector-for-each <? (bytevector 1 2) #inert))
($check-error (bytevector-for-each cons
(bytevector 1 2 3)))
+
+
+;; $when
+($check-error ($when))
+($check-error ($when #t . 3))
+($check-error ($when #f . 3))
+($check-error ($when #inert 1))
+
+;; $unless
+($check-error ($unless))
+($check-error ($unless #t . 3))
+($check-error ($unless #f . 3))
+($check-error ($unless #inert 1))
+
+
+
