diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c index 1d2d28a..cc67959 100644 --- a/examples/lisp/uns_lisp.c +++ b/examples/lisp/uns_lisp.c @@ -837,7 +837,7 @@ static void gensym(struct uns_ctr *id) char buf[64]; int len; - len = sprintf(buf, "__%08lx", l); + len = sprintf(buf, "__%lx", l); alloc_symbol_from_cstring(id, buf, len); l++; @@ -932,6 +932,7 @@ enum cps_return { CPS_LIST_UNDERFLOW, CPS_LIST_IMPROPER_LIST, CPS_EXEC_INVALID_APPL_LIST, + CPS_APP_UNDERFLOW, CPS_RETURN_LEN }; @@ -964,6 +965,7 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_LIST_INCONSISTENT_LIST", "CPS_LIST_IMPROPER_LIST", "CPS_EXEC_INVALID_APPL_LIST", + "CPS_APP_UNDERFLOW", "CPS_LIST_UNDERFLOW" }; @@ -1654,6 +1656,40 @@ end: return r; } +/* {K f} {cps-app} = {(kappa f K)} {cps} */ +static enum cps_return cps_app(struct uns_ctr *prevstack, + struct uns_ctr *readstack) +{ + struct uns_ctr K = {0}; + struct uns_ctr fsymb = {0}; + struct uns_ctr expr = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &K); + uns_root_add(gc, &fsymb); + uns_root_add(gc, &expr); + + if (!stack_pop(prevstack, &K) + || !stack_pop(prevstack, &fsymb)) { + r = CPS_APP_UNDERFLOW; + goto end; + } + + expr.p = empty_list.p; + stack_push(&expr, &K); + stack_push(&expr, &fsymb); + stack_push_const(&expr, "K"); + stack_push(prevstack, &expr); + + stack_push_const(readstack, "cps"); + +end: + uns_root_remove(gc, &K); + uns_root_remove(gc, &fsymb); + uns_root_remove(gc, &expr); + return r; +} + static enum cps_return cps(struct uns_ctr *prevstack, struct uns_ctr *readstack) { @@ -1678,6 +1714,8 @@ static enum cps_return cps(struct uns_ctr *prevstack, r = cps_exec(prevstack, readstack); } else if (strcmp(cmd, "cps-list") == 0) { r = cps_list(prevstack, readstack); + } else if (strcmp(cmd, "cps-app") == 0) { + r = cps_app(prevstack, readstack); } else { r = CPS_INVALID_CMD; }