diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2012-01-11 14:16:36 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2012-01-11 14:16:36 -0800 |
commit | 7639a095e61af6c9c0f502957b7ff2c3817acab1 (patch) | |
tree | 859013930ed2c926780c0abf0b5db8e17fee7719 /eval.c | |
parent | 285cf6a287d4d2de7d02bb1d72f369226e19c213 (diff) | |
download | txr-7639a095e61af6c9c0f502957b7ff2c3817acab1.tar.gz txr-7639a095e61af6c9c0f502957b7ff2c3817acab1.tar.bz2 txr-7639a095e61af6c9c0f502957b7ff2c3817acab1.zip |
* eval.c (each_s, each_star_s, collect_each_s, collect_each_star_s):
New symbol variables.
(op_each): New static function.
(expand): Handle the four new operators.
(eval_init): Intern new symbols, register new operators.
* txr.1: Documented each, each*, collect-each and collect-each*.
* txr.vim: Updated.
Diffstat (limited to 'eval.c')
-rw-r--r-- | eval.c | 61 |
1 files changed, 59 insertions, 2 deletions
@@ -54,7 +54,9 @@ val eval_error_s; val progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s; val cond_s, if_s, defvar_s, defun_s; val inc_s, dec_s, push_s, pop_s, flip_s, gethash_s, car_s, cdr_s, vecref_s; -val for_s, for_star_s, dohash_s, uw_protect_s, return_s, return_from_s; +val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s; +val dohash_s; +val uw_protect_s, return_s, return_from_s; val list_s, append_s, apply_s, gen_s, generate_s; val delay_s, promise_s; @@ -461,6 +463,50 @@ static val op_let(val form, val env) return eval_progn(body, make_env(new_bindings, nil, env), form); } +static val op_each(val form, val env) +{ + uses_or2; + val each = first(form); + val args = rest(form); + val vars = first(args); + val body = rest(args); + val star = or2(eq(each, each_star_s), eq(each, collect_each_star_s)); + val collect = or2(eq(each, collect_each_s), eq(each, collect_each_star_s)); + val new_bindings = bindings_helper(vars, env, star, form); + val lists = mapcar(cdr_f, new_bindings); + list_collect_decl (collection, ptail); + + uw_block_begin (nil, result); + + for (;;) { + val biter, liter; + + for (biter = new_bindings, liter = lists; biter; + biter = cdr(biter), liter = cdr(liter)) + { + val binding = car(biter); + val list = car(liter); + if (!list) + goto out; + rplacd(binding, car(list)); + rplaca(liter, cdr(list)); + } + + { + val res = eval_progn(body, make_env(new_bindings, nil, env), form); + if (collect) + list_collect(ptail, res); + } + } + +out: + result = collection; + + uw_block_end; + + return result; +} + static val op_lambda(val form, val env) { return func_interp(env, form); @@ -1010,7 +1056,10 @@ val expand(val form) } else { val sym = car(form); - if (sym == let_s || sym == let_star_s || sym == lambda_s) { + if (sym == let_s || sym == let_star_s || sym == lambda_s || + sym == each_s || sym == each_star_s || sym == collect_each_s || + sym == collect_each_star_s) + { val body = rest(rest(form)); val vars = second(form); val body_ex = expand_forms(body); @@ -1411,6 +1460,10 @@ void eval_init(void) flip_s = intern(lit("flip"), user_package); for_s = intern(lit("for"), user_package); for_star_s = intern(lit("for*"), user_package); + each_s = intern(lit("each"), user_package); + each_star_s = intern(lit("each*"), user_package); + collect_each_s = intern(lit("collect-each"), user_package); + collect_each_star_s = intern(lit("collect-each*"), user_package); dohash_s = intern(lit("dohash"), user_package); uw_protect_s = intern(lit("unwind-protect"), user_package); return_s = intern(lit("return"), user_package); @@ -1434,6 +1487,10 @@ void eval_init(void) sethash(op_table, progn_s, cptr((mem_t *) op_progn)); sethash(op_table, prog1_s, cptr((mem_t *) op_prog1)); sethash(op_table, let_s, cptr((mem_t *) op_let)); + sethash(op_table, each_s, cptr((mem_t *) op_each)); + sethash(op_table, each_star_s, cptr((mem_t *) op_each)); + sethash(op_table, collect_each_s, cptr((mem_t *) op_each)); + sethash(op_table, collect_each_star_s, cptr((mem_t *) op_each)); sethash(op_table, let_star_s, cptr((mem_t *) op_let)); sethash(op_table, lambda_s, cptr((mem_t *) op_lambda)); sethash(op_table, call_s, cptr((mem_t *) op_call)); |