From 504311f99951317a7baf7028264ef8b703142a16 Mon Sep 17 00:00:00 2001
From: Peter McGoron <code@mcgoron.com>
Date: Tue, 16 Jul 2024 15:16:26 -0400
Subject: [PATCH] uns_lisp: cps-if

---
 examples/lisp/uns_lisp.c | 98 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 89 insertions(+), 9 deletions(-)

diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c
index d58b0c9..c9ba1e0 100644
--- a/examples/lisp/uns_lisp.c
+++ b/examples/lisp/uns_lisp.c
@@ -1022,8 +1022,8 @@ enum cps_return {
 	CPS_CALLCC_UNDERFLOW,
 	CPS_CALLCC_SYMBOL,
 	CPS_CALLCC_OVERFLOW,
-	CPS_IF_UNDERFLOW,
-	CPS_IF_OVERFLOW,
+	CPS_EXEC_IF_UNDERFLOW,
+	CPS_EXEC_IF_OVERFLOW,
 	CPS_UNQUOTE_INVALID,
 	CPS_UNQUOTE_LIST_INVALID,
 	CPS_NULL_EXPR,
@@ -1036,6 +1036,7 @@ enum cps_return {
 	CPS_APP_UNDERFLOW,
 	CPS_FCALL_IMPROPER_LIST,
 	CPS_SWAP_UNDERFLOW,
+	CPS_IF_UNDERFLOW,
 
 	CPS_RETURN_LEN
 };
@@ -1059,8 +1060,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
 	"CPS_CALLCC_UNDERFLOW",
 	"CPS_CALLCC_SYMBOL",
 	"CPS_CALLCC_OVERFLOW",
-	"CPS_IF_UNDERFLOW",
-	"CPS_IF_OVERFLOW",
+	"CPS_EXEC_IF_UNDERFLOW",
+	"CPS_EXEC_IF_OVERFLOW",
 	"CPS_UNQUOTE_INVALID",
 	"CPS_UNQUOTE_LIST_INVALID",
 	"CPS_NULL_EXPR",
@@ -1072,7 +1073,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
 	"CPS_EXEC_INVALID_APPL_LIST",
 	"CPS_APP_UNDERFLOW",
 	"CPS_FCALL_IMPROPER_LIST",
-	"CPS_SWAP_UNDERFLOW"
+	"CPS_SWAP_UNDERFLOW",
+	"CPS_IF_UNDERFLOW"
 };
 
 /* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */
@@ -1379,20 +1381,20 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
 	gensym(&newk);
 
 	if (get_type(lst->p) != CELL)
-		return CPS_IF_UNDERFLOW;
+		return CPS_EXEC_IF_UNDERFLOW;
 	e.p = CAR(lst->p);
 	lst->p = CDR(lst->p);
 
 	if (get_type(lst->p) != CELL)
-		return CPS_IF_UNDERFLOW;
+		return CPS_EXEC_IF_UNDERFLOW;
 	b1.p = CAR(lst->p);
 	lst->p = CDR(lst->p);
 
 	if (get_type(lst->p) != CELL)
-		return CPS_IF_UNDERFLOW;
+		return CPS_EXEC_IF_UNDERFLOW;
 	b2.p = CAR(lst->p);
 	if (get_type(CDR(lst->p)) != EMPTY_LIST)
-		return CPS_IF_OVERFLOW;
+		return CPS_EXEC_IF_OVERFLOW;
 
 	stack_push(prevstack, &e);
 	stack_push(prevstack, K);
@@ -1740,6 +1742,9 @@ end:
 	return r;
 }
 
+/* {E0 E1 ... Eplaces} {swap_places}
+   = {E1 ... Eplaces E0} {}
+ */
 static enum cps_return cps_swap(struct uns_ctr *prevstack,
                                 int places,
                                 struct uns_ctr *readstack
@@ -1783,6 +1788,79 @@ end:
 	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,
                            struct uns_ctr *readstack)
 {
@@ -1809,6 +1887,8 @@ static enum cps_return cps(struct uns_ctr *prevstack,
 		r = cps_list(prevstack, readstack);
 	} else if (strcmp(cmd, "swap2") == 0) {
 		r = cps_swap(prevstack, 2, readstack);
+	} else if (strcmp(cmd, "cps-if") == 0) {
+		r = cps_if(prevstack, readstack);
 	} else {
 		r = CPS_INVALID_CMD;
 	}