uns_lisp: cps-lambda

1 files changed, 63 insertions, 10 deletions

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;
 	}