diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c index c9ba1e0..aa450a1 100644 --- a/examples/lisp/uns_lisp.c +++ b/examples/lisp/uns_lisp.c @@ -1013,8 +1013,8 @@ enum cps_return { CPS_QUOTE_OVERFLOW, CPS_QUASIQUOTE_UNDERFLOW, CPS_QUASIQUOTE_OVERFLOW, - CPS_LAMBDA_UNDERFLOW, - CPS_LAMBDA_OVERFLOW, + CPS_EXEC_LAMBDA_UNDERFLOW, + CPS_EXEC_LAMBDA_OVERFLOW, CPS_INVALID_LAMBDA_FORMAL, CPS_DYNAMIC_WIND_UNDERFLOW, CPS_DYNAMIC_WIND_SYMBOL, @@ -1037,6 +1037,7 @@ enum cps_return { CPS_FCALL_IMPROPER_LIST, CPS_SWAP_UNDERFLOW, CPS_IF_UNDERFLOW, + CPS_LAMBDA_UNDERFLOW, CPS_RETURN_LEN }; @@ -1051,8 +1052,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_QUOTE_OVERFLOW", "CPS_QUASIQUOTE_UNDERFLOW", "CPS_QUASIQUOTE_OVERFLOW", - "CPS_LAMBDA_UNDERFLOW", - "CPS_LAMBDA_OVERFLOW", + "CPS_EXEC_LAMBDA_UNDERFLOW", + "CPS_EXEC_LAMBDA_OVERFLOW", "CPS_INVALID_LAMBDA_FORMAL", "CPS_DYNAMIC_WIND_UNDERFLOW", "CPS_DYNAMIC_WIND_SYMBOL", @@ -1074,7 +1075,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_APP_UNDERFLOW", "CPS_FCALL_IMPROPER_LIST", "CPS_SWAP_UNDERFLOW", - "CPS_IF_UNDERFLOW" + "CPS_IF_UNDERFLOW", + "CPS_LAMBDA_UNDERFLOW" }; /* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */ @@ -1141,8 +1143,6 @@ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, /* {K (lambda l BODY)} {cps} = {k BODY l k K} {cps cps-lambda} - - {LAMBODY l k K} {cps-lambda} = {(-> (lambda l (kappa k LAMBODY))) K)} */ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack, struct uns_ctr *K, @@ -1171,7 +1171,7 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack, \ tmp.p */ tmp.p = CAR(rest->p); switch (get_type(tmp.p)) { - case SYMBOL: case LISP_NULL: case EMPTY_LIST: + case SYMBOL: case EMPTY_LIST: case CELL: break; default: r = CPS_INVALID_LAMBDA_FORMAL; @@ -1182,12 +1182,12 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack, rest->p = CDR(rest->p); if (get_type(rest->p) != CELL) { - r = CPS_LAMBDA_UNDERFLOW; + r = CPS_EXEC_LAMBDA_UNDERFLOW; goto cleanup; } if (get_type(CDR(rest->p)) != EMPTY_LIST) { - r = CPS_LAMBDA_OVERFLOW; + r = CPS_EXEC_LAMBDA_OVERFLOW; goto cleanup; } @@ -1861,6 +1861,57 @@ end: return r; } +/* + {LAMBODY l k K} {cps-lambda} = {(-> (lambda-kappa l k LAMBODY)) K)} + */ +static enum cps_return cps_lambda(struct uns_ctr *prevstack) +{ + struct uns_ctr lambody = {0}; + struct uns_ctr l = {0}; + struct uns_ctr ksymb = {0}; + struct uns_ctr K = {0}; + struct uns_ctr tmp = {0}; + struct uns_ctr body = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &lambody); + uns_root_add(gc, &l); + uns_root_add(gc, &ksymb); + uns_root_add(gc, &K); + uns_root_add(gc, &tmp); + uns_root_add(gc, &body); + + if (!stack_pop(prevstack, &lambody) + || !stack_pop(prevstack, &l) + || !stack_pop(prevstack, &ksymb) + || !stack_pop(prevstack, &K)) { + r = CPS_LAMBDA_UNDERFLOW; + goto end; + } + + body.p = empty_list.p; + stack_push(&body, &lambody); + stack_push(&body, &ksymb); + stack_push(&body, &l); + stack_push_const(&body, "LK"); + + tmp.p = body.p; + body.p = empty_list.p; + stack_push(&body, &K); + stack_push(&body, &tmp); + stack_push_const(&body, "->"); + + stack_push(prevstack, &body); +end: + uns_root_remove(gc, &lambody); + uns_root_remove(gc, &l); + uns_root_remove(gc, &ksymb); + uns_root_remove(gc, &K); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &body); + return r; +} + static enum cps_return cps(struct uns_ctr *prevstack, struct uns_ctr *readstack) { @@ -1889,6 +1940,8 @@ static enum cps_return cps(struct uns_ctr *prevstack, r = cps_swap(prevstack, 2, readstack); } else if (strcmp(cmd, "cps-if") == 0) { r = cps_if(prevstack, readstack); + } else if (strcmp(cmd, "cps-lambda") == 0) { + r = cps_lambda(prevstack); } else { r = CPS_INVALID_CMD; }