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

uns_lisp: cps-if

This commit is contained in:
Peter McGoron 2024-07-16 15:16:26 -04:00
parent f440716bf9
commit 504311f999
1 changed files with 89 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
examples/lisp/uns_lisp.c
View File

@ -1022,8 +1022,8 @@ enum cps_return {
CPS_CALLCC_UNDERFLOW, CPS_CALLCC_UNDERFLOW,
CPS_CALLCC_SYMBOL, CPS_CALLCC_SYMBOL,
CPS_CALLCC_OVERFLOW, CPS_CALLCC_OVERFLOW,
CPS_IF_UNDERFLOW, CPS_EXEC_IF_UNDERFLOW,
CPS_IF_OVERFLOW, CPS_EXEC_IF_OVERFLOW,
CPS_UNQUOTE_INVALID, CPS_UNQUOTE_INVALID,
CPS_UNQUOTE_LIST_INVALID, CPS_UNQUOTE_LIST_INVALID,
CPS_NULL_EXPR, CPS_NULL_EXPR,
@ -1036,6 +1036,7 @@ enum cps_return {
CPS_APP_UNDERFLOW, CPS_APP_UNDERFLOW,
CPS_FCALL_IMPROPER_LIST, CPS_FCALL_IMPROPER_LIST,
CPS_SWAP_UNDERFLOW, CPS_SWAP_UNDERFLOW,
CPS_IF_UNDERFLOW,
CPS_RETURN_LEN CPS_RETURN_LEN
}; };
@ -1059,8 +1060,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_CALLCC_UNDERFLOW", "CPS_CALLCC_UNDERFLOW",
"CPS_CALLCC_SYMBOL", "CPS_CALLCC_SYMBOL",
"CPS_CALLCC_OVERFLOW", "CPS_CALLCC_OVERFLOW",
"CPS_IF_UNDERFLOW", "CPS_EXEC_IF_UNDERFLOW",
"CPS_IF_OVERFLOW", "CPS_EXEC_IF_OVERFLOW",
"CPS_UNQUOTE_INVALID", "CPS_UNQUOTE_INVALID",
"CPS_UNQUOTE_LIST_INVALID", "CPS_UNQUOTE_LIST_INVALID",
"CPS_NULL_EXPR", "CPS_NULL_EXPR",
@ -1072,7 +1073,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_EXEC_INVALID_APPL_LIST", "CPS_EXEC_INVALID_APPL_LIST",
"CPS_APP_UNDERFLOW", "CPS_APP_UNDERFLOW",
"CPS_FCALL_IMPROPER_LIST", "CPS_FCALL_IMPROPER_LIST",
"CPS_SWAP_UNDERFLOW" "CPS_SWAP_UNDERFLOW",
"CPS_IF_UNDERFLOW"
}; };
/* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */ /* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */
@ -1379,20 +1381,20 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
gensym(&newk); gensym(&newk);
if (get_type(lst->p) != CELL) if (get_type(lst->p) != CELL)
return CPS_IF_UNDERFLOW; return CPS_EXEC_IF_UNDERFLOW;
e.p = CAR(lst->p); e.p = CAR(lst->p);
lst->p = CDR(lst->p); lst->p = CDR(lst->p);
if (get_type(lst->p) != CELL) if (get_type(lst->p) != CELL)
return CPS_IF_UNDERFLOW; return CPS_EXEC_IF_UNDERFLOW;
b1.p = CAR(lst->p); b1.p = CAR(lst->p);
lst->p = CDR(lst->p); lst->p = CDR(lst->p);
if (get_type(lst->p) != CELL) if (get_type(lst->p) != CELL)
return CPS_IF_UNDERFLOW; return CPS_EXEC_IF_UNDERFLOW;
b2.p = CAR(lst->p); b2.p = CAR(lst->p);
if (get_type(CDR(lst->p)) != EMPTY_LIST) if (get_type(CDR(lst->p)) != EMPTY_LIST)
return CPS_IF_OVERFLOW; return CPS_EXEC_IF_OVERFLOW;
stack_push(prevstack, &e); stack_push(prevstack, &e);
stack_push(prevstack, K); stack_push(prevstack, K);
@ -1740,6 +1742,9 @@ end:
return r; return r;
} }
/* {E0 E1 ... Eplaces} {swap_places}
= {E1 ... Eplaces E0} {}
*/
static enum cps_return cps_swap(struct uns_ctr *prevstack, static enum cps_return cps_swap(struct uns_ctr *prevstack,
int places, int places,
struct uns_ctr *readstack struct uns_ctr *readstack
@ -1783,6 +1788,79 @@ end:
return r; return r;
} }
/* {Ktrue Kfalse k Kafter E} {cps-if}
= {(kappa e (if-> e (kappa k Ktrue) (kappa k Kfalse) Kafter)) E} {cps}
*/
static enum cps_return cps_if(struct uns_ctr *prevstack,
struct uns_ctr *readstack
)
{
struct uns_ctr k_true = {0};
struct uns_ctr k_false = {0};
struct uns_ctr k = {0};
struct uns_ctr k_after = {0};
struct uns_ctr expr = {0};
struct uns_ctr tmp = {0};
struct uns_ctr e_expr = {0};
enum cps_return r = CPS_CONTINUE;
uns_root_add(gc, &k_true);
uns_root_add(gc, &k_false);
uns_root_add(gc, &k);
uns_root_add(gc, &k_after);
uns_root_add(gc, &expr);
uns_root_add(gc, &tmp);
if (!stack_pop(prevstack, &k_true)
|| !stack_pop(prevstack, &k_false)
|| !stack_pop(prevstack, &k)
|| !stack_pop(prevstack, &k_after)) {
r = CPS_IF_UNDERFLOW;
goto end;
}
gensym(&e_expr);
expr.p = empty_list.p;
stack_push(&expr, &k_after);
tmp.p = empty_list.p;
stack_push(&tmp, &k_false);
stack_push(&tmp, &k);
stack_push_const(&tmp, "K");
stack_push(&expr, &tmp);
tmp.p = empty_list.p;
stack_push(&tmp, &k_true);
stack_push(&tmp, &k);
stack_push_const(&tmp, "K");
stack_push(&expr, &tmp);
gensym(&e_expr);
stack_push(&expr, &e_expr);
stack_push_const(&expr, "if->");
tmp.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, &tmp);
stack_push(&expr, &e_expr);
stack_push_const(&expr, "K");
stack_push(prevstack, &expr);
stack_push_const(readstack, "cps");
end:
uns_root_remove(gc, &k_true);
uns_root_remove(gc, &k_false);
uns_root_remove(gc, &k);
uns_root_remove(gc, &k_after);
uns_root_remove(gc, &expr);
uns_root_remove(gc, &tmp);
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)
{ {
@ -1809,6 +1887,8 @@ static enum cps_return cps(struct uns_ctr *prevstack,
r = cps_list(prevstack, readstack); r = cps_list(prevstack, readstack);
} else if (strcmp(cmd, "swap2") == 0) { } else if (strcmp(cmd, "swap2") == 0) {
r = cps_swap(prevstack, 2, readstack); r = cps_swap(prevstack, 2, readstack);
} else if (strcmp(cmd, "cps-if") == 0) {
r = cps_if(prevstack, readstack);
} else { } else {
r = CPS_INVALID_CMD; r = CPS_INVALID_CMD;
} }