uns_lisp: cps transformation of function arguments

1 files changed, 195 insertions, 38 deletions

diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c
index d90f8c5..1d2d28a 100644
--- a/examples/lisp/uns_lisp.c
+++ b/examples/lisp/uns_lisp.c
@@ -928,6 +928,10 @@ enum cps_return {
 	CPS_UNQUOTE_LIST_INVALID,
 	CPS_NULL_EXPR,
 	CPS_INVALID_CMD,
+	CPS_LIST_INCONSISTENT_LIST,
+	CPS_LIST_UNDERFLOW,
+	CPS_LIST_IMPROPER_LIST,
+	CPS_EXEC_INVALID_APPL_LIST,
 
 	CPS_RETURN_LEN
 };
@@ -956,7 +960,11 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
 	"CPS_UNQUOTE_INVALID",
 	"CPS_UNQUOTE_LIST_INVALID",
 	"CPS_INVALID_CMD",
-	"CPS_NULL_EXPR"
+	"CPS_NULL_EXPR",
+	"CPS_LIST_INCONSISTENT_LIST",
+	"CPS_LIST_IMPROPER_LIST",
+	"CPS_EXEC_INVALID_APPL_LIST",
+	"CPS_LIST_UNDERFLOW"
 };
 
 /* {K (quote QUOTED)} {cps} = {(-> QUOTED K)} */
@@ -979,7 +987,7 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack,
 	wrapped.p = empty_list.p;
 	stack_push(&wrapped, K);
 	stack_push(&wrapped, quoted);
-	stack_push_const(&wrapped, "__->");
+	stack_push_const(&wrapped, "->");
 
 	stack_push(prevstack, &wrapped);
 
@@ -1021,7 +1029,7 @@ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack,
 	stack_push(prevstack, &tmp);
 	stack_push(prevstack, K);
 
-	stack_push_const(readstack, "__quasiquote");
+	stack_push_const(readstack, "quasiquote");
 
 	uns_root_remove(gc, &tmpint);
 	uns_root_remove(gc, &tmp);
@@ -1164,13 +1172,13 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
 	stack_push(&expr, &bound_k);
 	stack_push(&expr, &empty_list);
 	stack_push(&expr, &thunk);
-	stack_push_const(&expr, "__A"); /* (__A thunk '() bound_k) */
+	stack_push_const(&expr, "A"); /* (__A thunk '() bound_k) */
 
 	tmp1.p = expr.p;
 	expr.p = empty_list.p;
 	stack_push(&expr, &tmp1);
 	stack_push(&expr, &bound_k);
-	stack_push_const(&expr, "__K"); /* (__K bound_k (__A thunk '() bound_k)) */
+	stack_push_const(&expr, "K"); /* (__K bound_k (__A thunk '() bound_k)) */
 
 	tmp1.p = expr.p;
 	expr.p = empty_list.p;
@@ -1178,7 +1186,7 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
 	stack_push(&expr, &tmp1);
 	stack_push(&expr, &after);
 	stack_push(&expr, &before);
-	stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */
+	stack_push_const(&expr, "K/H"); /* (__K/H before after (...) K) */
 
 	stack_push(prevstack, &expr);
 
@@ -1225,19 +1233,19 @@ static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack,
 	stack_push(&expr, &newk);
 	stack_push(&expr, &newk);
 	stack_push(&expr, &f);
-	stack_push_const(&expr, "__A"); /* (__A f k k) */
+	stack_push_const(&expr, "A"); /* (__A f k k) */
 
 	tmp.p = expr.p;
 	expr.p = empty_list.p;
 	stack_push(&expr, &tmp);
 	stack_push(&expr, &newk);
-	stack_push_const(&expr, "kappa"); /* (kappa k (__A f k k)) */
+	stack_push_const(&expr, "K"); /* (kappa k (__A f k k)) */
 
 	tmp.p = expr.p;
 	expr.p = empty_list.p;
 	stack_push(&expr, K);
 	stack_push(&expr, &tmp);
-	stack_push_const(&expr, "__<-"); /* (__<- (...) K) */
+	stack_push_const(&expr, "<-"); /* (__<- (...) K) */
 
 	stack_push(prevstack, &expr);
 
@@ -1305,7 +1313,41 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
 	return CPS_CONTINUE;
 }
 
-/* {K (f . L)} {cps} = {(kappa l (@ f l K)) '() L} {cps-list} */
+static int reverse(struct uns_ctr *into, struct uns_ctr *from)
+{
+	struct uns_ctr cell = {0};
+	struct uns_ctr tmp = {0};
+	int r = 1;
+
+	into->p = empty_list.p;
+	uns_root_add(gc, &tmp);
+	uns_root_add(gc, &cell);
+
+	if (get_type(from->p) == EMPTY_LIST)
+		goto end;
+	if (get_type(from->p) != CELL) {
+		r = 0;
+		goto end;
+	}
+
+	cell.p = from->p;
+	while (get_type(cell.p) != EMPTY_LIST) {
+		if (get_type(cell.p) != CELL) {
+			r = 0;
+			goto end;
+		}
+		tmp.p = CAR(cell.p);
+		stack_push(into, &tmp);
+		cell.p = CDR(cell.p);
+	}
+
+end:
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &cell);
+	return r;
+}
+
+/* {K (f . L)} {cps} = {(@ f l K) '() [rev L] l} {cps-list} */
 static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
                                       struct uns_ctr *K,
                                       struct uns_ctr *E,
@@ -1322,23 +1364,20 @@ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
 	uns_root_add(gc, &l);
 
 	gensym(&l);
+	stack_push(prevstack, &l);
+
+	tmp.p = CDR(E->p);
+	if (!reverse(&expr, &tmp))
+		return CPS_EXEC_INVALID_APPL_LIST;
+	stack_push(prevstack, &expr);
+	stack_push(prevstack, &empty_list);
 
 	expr.p = empty_list.p;
 	stack_push(&expr, K);
 	stack_push(&expr, &l);
 	tmp.p = CAR(E->p);
 	stack_push(&expr, &tmp);
-	stack_push_const(&expr, "__A"); /* (__A f l K) */
-
-	tmp.p = expr.p;
-	expr.p = empty_list.p;
-	stack_push(&expr, &tmp);
-	stack_push(&expr, &l);
-	stack_push_const(&expr, "__K"); /* (__K l (...)) */
-
-	tmp.p = CDR(E->p);
-	stack_push(prevstack, &tmp);
-	stack_push(prevstack, &empty_list);
+	stack_push_const(&expr, "A"); /* (__A f l K) */
 	stack_push(prevstack, &expr);
 
 	stack_push_const(readstack, "cps-list");
@@ -1349,7 +1388,7 @@ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
 	return CPS_CONTINUE;
 }
 
-/* {K (F . L)} {cps} = {(kappa l (@ f l K)) '() L f F} {cps-list cps-app} */
+/* {K (F . L)} {cps} = {(@ f l K) '() [rev L] l f F} {cps-list cps-app} */
 static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack,
                                                struct uns_ctr *K,
                                                struct uns_ctr *E,
@@ -1371,21 +1410,20 @@ static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack,
 	tmp.p = CAR(E->p);
 	stack_push(prevstack, &tmp);
 	stack_push(prevstack, &f);
+
+	stack_push(prevstack, &l);
+
 	tmp.p = CDR(E->p);
-	stack_push(prevstack, &tmp);
+	if (!reverse(&expr, &tmp))
+		return CPS_EXEC_INVALID_APPL_LIST;
+	stack_push(prevstack, &expr);
 	stack_push(prevstack, &empty_list);
 
 	expr.p = empty_list.p;
 	stack_push(&expr, K);
 	stack_push(&expr, &l);
 	stack_push(&expr, &f);
-	stack_push_const(&expr, "__A"); /* (__A f l K) */
-
-	tmp.p = expr.p;
-	expr.p = empty_list.p;
-	stack_push(&expr, &tmp);
-	stack_push(&expr, &l);
-	stack_push_const(&expr, "__K"); /* (__K l (f l K)) */
+	stack_push_const(&expr, "A"); /* (__A f l K) */
 	stack_push(prevstack, &expr);
 
 	stack_push_const(readstack, "cps-app");
@@ -1482,7 +1520,7 @@ static enum cps_return cps_exec(struct uns_ctr *prevstack,
 	case EMPTY_LIST:
 		stack_push(&tmp, &K);
 		stack_push(&tmp, &E);
-		stack_push_const(&tmp, "__->");
+		stack_push_const(&tmp, "->");
 		stack_push(prevstack, &tmp);
 		break;
 	case CELL:
@@ -1501,6 +1539,121 @@ end:
 	return r;
 }
 
+/* {K HEAD '() l} {cps-list} = {(-> HEAD (kappa l K))} {} */
+static enum cps_return cps_list_final(struct uns_ctr *prevstack,
+                                      struct uns_ctr *K,
+                                      struct uns_ctr *head,
+                                      struct uns_ctr *l
+                                     )
+{
+	struct uns_ctr expr = {0};
+	struct uns_ctr tmp = {0};
+
+	uns_root_add(gc, &expr);
+	uns_root_add(gc, &tmp);
+
+	expr.p = empty_list.p;
+	stack_push(&expr, K);
+	stack_push(&expr, l);
+	stack_push_const(&expr, "K");
+
+	tmp.p = expr.p;
+	expr.p = empty_list.p;
+	stack_push(&expr, &tmp);
+	stack_push(&expr, head);
+	stack_push_const(&expr, "->");
+
+	stack_push(prevstack, &expr);
+
+	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &tmp);
+	return CPS_CONTINUE;
+}
+
+/* {K HEAD (A . B) l} {cps-list} =
+     {(kappa a K) A [cons a HEAD] B l} {cps cps-list}
+ */
+static enum cps_return cps_list_cell(struct uns_ctr *prevstack,
+                                     struct uns_ctr *K,
+                                     struct uns_ctr *head,
+                                     struct uns_ctr *args,
+                                     struct uns_ctr *readstack
+                                    )
+{
+	struct uns_ctr expr = {0};
+	struct uns_ctr atmp = {0};
+	enum cps_return r = CPS_CONTINUE;
+
+	uns_root_add(gc, &expr);
+	uns_root_add(gc, &atmp);
+	gensym(&atmp);
+
+	expr.p = CDR(args->p);
+	stack_push(prevstack, &expr);
+	cons(&expr, &atmp, head);
+	stack_push(prevstack, &expr);
+	expr.p = CAR(args->p);
+	stack_push(prevstack, &expr);
+
+	expr.p = empty_list.p;
+	stack_push(&expr, K);
+	stack_push(&expr, &atmp);
+	stack_push_const(&expr, "K");
+	stack_push(prevstack, &expr);
+
+	stack_push_const(readstack, "cps-list");
+	stack_push_const(readstack, "cps");
+
+	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &atmp);
+	return r;
+}
+
+/* {K HEAD ARGS l} {cps-list}
+ */
+static enum cps_return cps_list(struct uns_ctr *prevstack,
+                                struct uns_ctr *readstack
+                               )
+{
+	struct uns_ctr K = {0};
+	struct uns_ctr head = {0};
+	struct uns_ctr args = {0};
+	struct uns_ctr l = {0};
+	enum cps_return r = CPS_CONTINUE;
+
+	uns_root_add(gc, &K);
+	uns_root_add(gc, &head);
+	uns_root_add(gc, &args);
+	uns_root_add(gc, &l);
+
+	if (!stack_pop(prevstack, &K)
+	    || !stack_pop(prevstack, &head)
+	    || !stack_pop(prevstack, &args)
+	    || !stack_pop(prevstack, &l)) {
+		r = CPS_LIST_UNDERFLOW;
+		goto end;
+	}
+
+	switch (get_type(args.p)) {
+	case EMPTY_LIST:
+		r = cps_list_final(prevstack, &K, &head, &l);
+		break;
+	case CELL:
+		stack_push(prevstack, &l);
+		r = cps_list_cell(prevstack, &K, &head, &args, readstack);
+		break;
+	default:
+		r = CPS_LIST_IMPROPER_LIST;
+		break;
+	}
+end:
+	uns_root_remove(gc, &K);
+	uns_root_remove(gc, &head);
+	uns_root_remove(gc, &args);
+	uns_root_remove(gc, &l);
+	return r;
+}
+
 static enum cps_return cps(struct uns_ctr *prevstack,
                            struct uns_ctr *readstack)
 {
@@ -1523,6 +1676,8 @@ static enum cps_return cps(struct uns_ctr *prevstack,
 
 	if (strcmp(cmd, "cps") == 0) {
 		r = cps_exec(prevstack, readstack);
+	} else if (strcmp(cmd, "cps-list") == 0) {
+		r = cps_list(prevstack, readstack);
 	} else {
 		r = CPS_INVALID_CMD;
 	}
@@ -1644,6 +1799,7 @@ int main(void)
 	struct uns_ctr prevstack = {0};
 	struct uns_ctr readstack = {0};
 	struct file input = {0};
+	enum cps_return r;
 	input.loc.line = 1;
 
 	init();
@@ -1656,7 +1812,6 @@ int main(void)
 		expr.p = NULL;
 		switch (expr_parse(&input, &expr)) {
 		case EXPR_PARSE_OK:
-			fprintf(stderr, "parse finished\n");
 			expr.p = uns_get(gc, expr.p, 0, NULL);
 			display(&expr);
 			break;
@@ -1689,12 +1844,14 @@ int main(void)
 		}
 
 		cps_init(&prevstack, &readstack, &expr);
-		fprintf(stderr, "cps: %s\n", cps_return_to_string[cps(&prevstack, &readstack)]);
-		printf("Prev: {\n");
-		display(&prevstack);
-		printf("}\nRead: {\n");
-		display(&readstack);
-		printf("}\n");
+		do {
+			printf("Prev: {\n");
+			display(&prevstack);
+			printf("}\nRead: {\n");
+			display(&readstack);
+			printf("}\n");
+			r = cps(&prevstack, &readstack);
+		} while (r == CPS_CONTINUE);
 	}
 
 cleanup: