klisp

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

commit d5a6a5c710dd6cddad4593c7948d77eacb332271
parent 0afe15922ebf0a87b04513f39bbc57b6ee5f7a17
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu,  7 Apr 2011 14:09:09 -0300

Added map to the ground environment.

Diffstat:
Msrc/kgcombiners.c | 365++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
Msrc/kgcombiners.h | 2+-
Msrc/kgpairs_lists.c | 4+---
Msrc/kground.c | 3+--
4 files changed, 367 insertions(+), 7 deletions(-)

diff --git a/src/kgcombiners.c b/src/kgcombiners.c @@ -146,8 +146,371 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree, ktail_eval(K, expr, env); } +/* Helpers for map (also used by for each) + They are inline because they are only used twice */ +inline void map_for_each_get_metrics(klisp_State *K, char *name, TValue lss, + int32_t *app_apairs_out, int32_t *app_cpairs_out, + int32_t *res_apairs_out, int32_t *res_cpairs_out) +{ + /* avoid warnings (shouldn't happen if _No_return was used in throw) */ + *app_apairs_out = 0; + *app_cpairs_out = 0; + *res_apairs_out = 0; + *res_cpairs_out = 0; + + /* get the metrics of the ptree of each call to app */ + int32_t app_cpairs; + int32_t app_pairs = check_list(K, name, true, lss, &app_cpairs); + int32_t app_apairs = app_pairs - app_cpairs; + + /* get the metrics of the result list */ + int32_t res_cpairs; + /* We now that lss has at least one elem */ + int32_t res_pairs = check_list(K, name, true, kcar(lss), &res_cpairs); + int32_t res_apairs = res_pairs - res_cpairs; + + if (res_cpairs == 0) { + /* finite list of length res_pairs (all lists should + have the same structure: acyclic with same length) */ + int32_t pairs = app_pairs - 1; + TValue tail = kcdr(lss); + while(pairs--) { + int32_t first_cpairs; + int32_t first_pairs = check_list(K, name, true, kcar(tail), + &first_cpairs); + tail = kcdr(tail); + + if (first_cpairs != 0) { + klispE_throw_extra(K, name, + ": mixed finite and infinite lists"); + return; + } else if (first_pairs != res_pairs) { + klispE_throw_extra(K, name, ": lists of different length"); + return; + } + } + } else { + /* cyclic list: all lists should be cyclic. + result will have acyclic length equal to the + max of all the lists and cyclic length equal to the lcm + of all the lists. res_pairs may be broken but will be + restored by after the loop */ + int32_t pairs = app_pairs - 1; + TValue tail = kcdr(lss); + while(pairs--) { + int32_t first_cpairs; + int32_t first_pairs = check_list(K, name, true, kcar(tail), + &first_cpairs); + int32_t first_apairs = first_pairs - first_cpairs; + tail = kcdr(tail); + + if (first_cpairs == 0) { + klispE_throw_extra(K, name, + ": mixed finite and infinite lists"); + return; + } + res_apairs = kmax32(res_apairs, first_apairs); + /* this can throw an error if res_cpairs doesn't + fit in 32 bits, which is a reasonable implementation + restriction because the list wouldn't fit in memory + anyways */ + res_cpairs = kcheck32(K, "map/for-each: result list is too big", + klcm32_64(res_cpairs, first_cpairs)); + } + res_pairs = kcheck32(K, "map/for-each: result list is too big", + (int64_t) res_cpairs + (int64_t) res_apairs); + UNUSED(res_pairs); + } + + *app_apairs_out = app_apairs; + *app_cpairs_out = app_cpairs; + *res_apairs_out = res_apairs; + *res_cpairs_out = res_cpairs; +} + +/* Return two lists, isomorphic to lss: one list of cars and one list + of cdrs (replacing the value of lss) */ +inline TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss, + int32_t apairs, int32_t cpairs) +{ + TValue tail = *lss; + + TValue dummy_cars = kcons(K, KINERT, KNIL); + TValue lp_cars = dummy_cars; + TValue lap_cars = dummy_cars; + + TValue dummy_cdrs = kcons(K, KINERT, KNIL); + TValue lp_cdrs = dummy_cdrs; + TValue lap_cdrs = dummy_cdrs; + + while(apairs != 0 || cpairs != 0) { + int32_t pairs; + if (apairs != 0) { + pairs = apairs; + } else { + /* remember last acyclic pair of both lists to to encycle! later */ + lap_cars = lp_cars; + lap_cdrs = lp_cdrs; + pairs = cpairs; + } + + while(pairs--) { + TValue first = kcar(tail); + tail = kcdr(tail); + + /* accumulate both cars and cdrs */ + TValue np; + np = kcons(K, kcar(first), KNIL); + kset_cdr(lp_cars, np); + lp_cars = np; + + np = kcons(K, kcdr(first), KNIL); + kset_cdr(lp_cdrs, np); + lp_cdrs = np; + } + + if (apairs != 0) { + apairs = 0; + } else { + cpairs = 0; + /* encycle! the list of cars and the list of cdrs */ + TValue fcp, lcp; + fcp = kcdr(lap_cars); + lcp = lp_cars; + kset_cdr(lcp, fcp); + + fcp = kcdr(lap_cdrs); + lcp = lp_cdrs; + kset_cdr(lcp, fcp); + } + } + + *lss = kcdr(dummy_cdrs); + return kcdr(dummy_cars); +} + +/* Transpose lss so that the result is a list of lists, each one having + metrics (app_apairs, app_cpairs). The metrics of the returned list + should be (res_apairs, res_cpairs) */ +inline TValue map_for_each_transpose(klisp_State *K, TValue lss, + int32_t app_apairs, int32_t app_cpairs, + int32_t res_apairs, int32_t res_cpairs) +{ + /* GC: root intermediate objects */ + TValue dummy = kcons(K, KINERT, KNIL); + TValue lp = dummy; + TValue lap = dummy; + + TValue tail = lss; + + /* Loop over list of lists, creating a list of cars and + a list of cdrs, accumulate the list of cars and loop + with the list of cdrs as the new list of lists (lss) */ + while(res_apairs != 0 || res_cpairs != 0) { + int32_t pairs; + + if (res_apairs != 0) { + pairs = res_apairs; + } else { + pairs = res_cpairs; + /* remember last acyclic pair to encycle! later */ + lap = lp; + } + + while(pairs--) { + /* accumulate cars and replace tail with cdrs */ + TValue cars = + map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs); + + TValue np = kcons(K, cars, KNIL); + kset_cdr(lp, np); + lp = np; + } + + if (res_apairs != 0) { + res_apairs = 0; + } else { + res_cpairs = 0; + /* encycle! the list of list of cars */ + TValue fcp = kcdr(lap); + TValue lcp = lp; + kset_cdr(lcp, fcp); + } + } + + return kcdr(dummy); +} + +/* Continuation helpers for map */ + +/* For acyclic input lists: Return the mapped list */ +void do_map_ret(klisp_State *K, TValue *xparams, TValue obj) +{ + /* + ** xparams[0]: (dummy . complete-ls) + */ + UNUSED(obj); + /* copy the list to avoid problems with continuations + captured from within the dynamic extent to map + and later mutation of the result */ + /* XXX: the check isn't necessary really, but there is + no list_copy */ + TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false); + kapply_cc(K, copy); +} + +/* For cyclic input list: close the cycle and return the mapped list */ +void do_map_encycle(klisp_State *K, TValue *xparams, TValue obj) +{ + /* + ** xparams[0]: (dummy . complete-ls) + ** xparams[1]: last non-cycle pair + */ + /* obj: (rem-ls . last-pair) */ + TValue lp = kcdr(obj); + TValue lap = xparams[1]; + + TValue fcp = kcdr(lap); + TValue lcp = lp; + kset_cdr(lcp, fcp); + + /* copy the list to avoid problems with continuations + captured from within the dynamic extent to map + and later mutation of the result */ + /* XXX: the check isn't necessary really, but there is + no list_copy */ + TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false); + kapply_cc(K, copy); +} + +void do_map(klisp_State *K, TValue *xparams, TValue obj) +{ + /* + ** xparams[0]: app + ** xparams[1]: rem-ls + ** xparams[2]: last-pair + ** xparams[3]: n + ** xparams[4]: denv + ** xparams[5]: dummyp + */ + TValue app = xparams[0]; + TValue ls = xparams[1]; + TValue last_pair = xparams[2]; + int32_t n = ivalue(xparams[3]); + TValue denv = xparams[4]; + bool dummyp = bvalue(xparams[5]); + + /* this case is used to kick start the mapping of both + the acyclic and cyclic part, avoiding code duplication */ + if (!dummyp) { + TValue np = kcons(K, obj, KNIL); + kset_cdr(last_pair, np); + last_pair = np; + } + + if (n == 0) { + /* pass the rest of the list and last pair for cycle handling */ + kapply_cc(K, kcons(K, ls, last_pair)); + } else { + /* copy the ptree to avoid problems with mutation */ + /* XXX: no check necessary, could just use copy_list if there + was such a procedure */ + TValue first_ptree = check_copy_list(K, "map", kcar(ls), false); + ls = kcdr(ls); + n = n-1; + /* have to unwrap the applicative to avoid extra evaluation of first */ + TValue new_expr = kcons(K, kunwrap(app), first_ptree); + TValue new_cont = + kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map, 6, app, + ls, last_pair, i2tv(n), denv, KFALSE); + kset_cc(K, new_cont); + ktail_eval(K, new_expr, denv); + } +} + +void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj) +{ + /* + ** xparams[0]: app + ** xparams[1]: (dummy . res-list) + ** xparams[2]: cpairs + ** xparams[3]: denv + */ + + TValue app = xparams[0]; + TValue dummy = xparams[1]; + int32_t cpairs = ivalue(xparams[2]); + TValue denv = xparams[3]; + + /* obj: (cycle-part . last-result-pair) */ + TValue ls = kcar(obj); + TValue last_apair = kcdr(obj); + + /* this continuation will close the cycle and return the list */ + TValue encycle_cont = + kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_encycle, 2, + dummy, last_apair); + + /* schedule the mapping of the elements of the cycle, + signal dummyp = true to avoid creating a pair for + the inert value passed to the first continuation */ + TValue new_cont = + kmake_continuation(K, encycle_cont, KNIL, KNIL, do_map, 6, app, ls, + last_apair, cpairs, denv, KTRUE); + kset_cc(K, new_cont); + /* this will be like a nop and will continue with do_map */ + kapply_cc(K, KINERT); +} + /* 5.9.1 map */ -/* TODO */ +void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) +{ + (void) xparams; + + bind_al1tp(K, "map", ptree, "applicative", ttisapplicative, app, + lss); + + if (ttisnil(lss)) { + klispE_throw(K, "map: no lists"); + return; + } + + /* get the metrics of the ptree of each call to app and + of the result list */ + int32_t app_pairs, app_apairs, app_cpairs; + int32_t res_pairs, res_apairs, res_cpairs; + + map_for_each_get_metrics(K, "map", lss, &app_apairs, &app_cpairs, + &res_apairs, &res_cpairs); + app_pairs = app_apairs + app_cpairs; + res_pairs = res_apairs + res_cpairs; + + /* create the list of parameters to app */ + lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs, + res_apairs, res_cpairs); + + /* 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? */ + + /* This will be the list to be returned, but it will be copied + before to play a little nicer with continuations */ + TValue dummy = kcons(K, KINERT, KNIL); + + TValue ret_cont = (res_cpairs == 0)? + kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_ret, 1, dummy) + : kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_cycle, 4, + app, dummy, i2tv(res_cpairs), denv); + /* schedule the mapping of the elements of the acyclic part. + signal dummyp = true to avoid creating a pair for + the inert value passed to the first continuation */ + TValue new_cont = + kmake_continuation(K, ret_cont, KNIL, KNIL, do_map, 6, app, lss, dummy, + i2tv(res_apairs), denv, KTRUE); + kset_cc(K, new_cont); + /* this will be a nop, and will continue with do_map */ + kapply_cc(K, KINERT); +} /* 6.2.1 combiner? */ /* uses ftypedp */ diff --git a/src/kgcombiners.h b/src/kgcombiners.h @@ -45,7 +45,7 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); /* 5.9.1 map */ -/* TODO */ +void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); /* 6.2.1 combiner? */ /* uses ftypedp */ diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c @@ -547,9 +547,7 @@ void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) UNUSED(denv); bind_2tp(K, "filter", ptree, "applicative", ttisapplicative, app, "any", anytype, ls); - /* copy the list to allow filtering by mutating pairs and - to avoid changes made by the applicative to alter the - structure of ls */ + /* copy the list to ignore changes made by the applicative */ /* REFACTOR: do this in a single pass */ /* ASK John: the semantics when this is mixed with continuations, isn't all that great..., but what are the expectations considering diff --git a/src/kground.c b/src/kground.c @@ -330,7 +330,7 @@ void kinit_ground_env(klisp_State *K) */ /* 5.9.1 map */ - /* TODO */ + add_applicative(K, ground_env, "map", map, 0); /* ** 5.10 Environments @@ -1004,5 +1004,4 @@ void kinit_ground_env(klisp_State *K) methods of opening. Also some directory checking, traversing etc */ return; - }