peter
/
universalservice
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

uns_lisp: cps-lambda

This commit is contained in:
Peter McGoron 2024-07-16 15:36:01 -04:00
parent 504311f999
commit 23ad070039
1 changed files with 63 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
examples/lisp/uns_lisp.c
View File

@ -1013,8 +1013,8 @@ enum cps_return {
CPS_QUOTE_OVERFLOW, CPS_QUOTE_OVERFLOW,
CPS_QUASIQUOTE_UNDERFLOW, CPS_QUASIQUOTE_UNDERFLOW,
CPS_QUASIQUOTE_OVERFLOW, CPS_QUASIQUOTE_OVERFLOW,
CPS_LAMBDA_UNDERFLOW, CPS_EXEC_LAMBDA_UNDERFLOW,
CPS_LAMBDA_OVERFLOW, CPS_EXEC_LAMBDA_OVERFLOW,
CPS_INVALID_LAMBDA_FORMAL, CPS_INVALID_LAMBDA_FORMAL,
CPS_DYNAMIC_WIND_UNDERFLOW, CPS_DYNAMIC_WIND_UNDERFLOW,
CPS_DYNAMIC_WIND_SYMBOL, CPS_DYNAMIC_WIND_SYMBOL,
@ -1037,6 +1037,7 @@ enum cps_return {
CPS_FCALL_IMPROPER_LIST, CPS_FCALL_IMPROPER_LIST,
CPS_SWAP_UNDERFLOW, CPS_SWAP_UNDERFLOW,
CPS_IF_UNDERFLOW, CPS_IF_UNDERFLOW,
CPS_LAMBDA_UNDERFLOW,
CPS_RETURN_LEN CPS_RETURN_LEN
}; };
@ -1051,8 +1052,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_QUOTE_OVERFLOW", "CPS_QUOTE_OVERFLOW",
"CPS_QUASIQUOTE_UNDERFLOW", "CPS_QUASIQUOTE_UNDERFLOW",
"CPS_QUASIQUOTE_OVERFLOW", "CPS_QUASIQUOTE_OVERFLOW",
"CPS_LAMBDA_UNDERFLOW", "CPS_EXEC_LAMBDA_UNDERFLOW",
"CPS_LAMBDA_OVERFLOW", "CPS_EXEC_LAMBDA_OVERFLOW",
"CPS_INVALID_LAMBDA_FORMAL", "CPS_INVALID_LAMBDA_FORMAL",
"CPS_DYNAMIC_WIND_UNDERFLOW", "CPS_DYNAMIC_WIND_UNDERFLOW",
"CPS_DYNAMIC_WIND_SYMBOL", "CPS_DYNAMIC_WIND_SYMBOL",
@ -1074,7 +1075,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_APP_UNDERFLOW", "CPS_APP_UNDERFLOW",
"CPS_FCALL_IMPROPER_LIST", "CPS_FCALL_IMPROPER_LIST",
"CPS_SWAP_UNDERFLOW", "CPS_SWAP_UNDERFLOW",
"CPS_IF_UNDERFLOW" "CPS_IF_UNDERFLOW",
"CPS_LAMBDA_UNDERFLOW"
}; };
/* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */ /* {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 (lambda l BODY)} {cps}
= {k BODY l k K} {cps cps-lambda} = {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, static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
struct uns_ctr *K, struct uns_ctr *K,
@ -1171,7 +1171,7 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
\ tmp.p */ \ tmp.p */
tmp.p = CAR(rest->p); tmp.p = CAR(rest->p);
switch (get_type(tmp.p)) { switch (get_type(tmp.p)) {
case SYMBOL: case LISP_NULL: case EMPTY_LIST: case SYMBOL: case EMPTY_LIST: case CELL:
break; break;
default: default:
r = CPS_INVALID_LAMBDA_FORMAL; 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); rest->p = CDR(rest->p);
if (get_type(rest->p) != CELL) { if (get_type(rest->p) != CELL) {
r = CPS_LAMBDA_UNDERFLOW; r = CPS_EXEC_LAMBDA_UNDERFLOW;
goto cleanup; goto cleanup;
} }
if (get_type(CDR(rest->p)) != EMPTY_LIST) { if (get_type(CDR(rest->p)) != EMPTY_LIST) {
r = CPS_LAMBDA_OVERFLOW; r = CPS_EXEC_LAMBDA_OVERFLOW;
goto cleanup; goto cleanup;
} }
@ -1861,6 +1861,57 @@ end:
return r; 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, static enum cps_return cps(struct uns_ctr *prevstack,
struct uns_ctr *readstack) struct uns_ctr *readstack)
{ {
@ -1889,6 +1940,8 @@ static enum cps_return cps(struct uns_ctr *prevstack,
r = cps_swap(prevstack, 2, readstack); r = cps_swap(prevstack, 2, readstack);
} else if (strcmp(cmd, "cps-if") == 0) { } else if (strcmp(cmd, "cps-if") == 0) {
r = cps_if(prevstack, readstack); r = cps_if(prevstack, readstack);
} else if (strcmp(cmd, "cps-lambda") == 0) {
r = cps_lambda(prevstack);
} else { } else {
r = CPS_INVALID_CMD; r = CPS_INVALID_CMD;
} }