uns_lisp: add first part of CPS transformer

2 files changed, 888 insertions, 103 deletions

diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c
index 5e89716..a42f7ad 100644
--- a/examples/lisp/uns_lisp.c
+++ b/examples/lisp/uns_lisp.c
@@ -24,14 +24,28 @@
  */
 
 #include <stdio.h>
+#include <stdarg.h>
 #include <string.h>
 #include <stdlib.h>
+#include <assert.h>
 #include "uns.h"
 #include "examples/string/uns_string.h"
 
 static Uns_GC gc;
 static struct uns_ctr empty_list;
 
+#define CAR(p) uns_get(gc, p, 1, NULL)
+#define CDR(p) uns_get(gc, p, 2, NULL)
+
+static void die(const char *fmt, ...)
+{
+	va_list va;
+	va_start(va, fmt);
+	vfprintf(stderr, fmt, va);
+	va_end(va);
+	exit(1);
+}
+
 enum token_type {
 	T_EOF,
 	LPAREN,
@@ -288,7 +302,6 @@ static void tokenize(struct file *input, struct token *tok)
 
 enum item_type {
 	CELL,
-	LAMBDA,
 	INTEGER,
 	FLOAT,
 	STRING,
@@ -312,14 +325,13 @@ static void alloc_of_type(struct uns_ctr *ctr, int typ)
 
 	switch (typ) {
 	case CELL: fields = 2; break;
-	case LAMBDA: fields = 2; break;
 	case INTEGER: fields = 1; break;
 	case STRING: fields = 1; break;
 	case SYMBOL: fields = 1; break;
 	case FLOAT: fields = 1; break;
 	case EMPTY_LIST: fields = 0; break;
 	case LISP_NULL: fields = 0; break;
-	default: abort();
+	default: die("Invalid type %d\n", typ);
 	}
 
 	ctr->p = uns_alloc_rec(gc, fields + 1, 0);
@@ -331,7 +343,18 @@ static void alloc_of_type(struct uns_ctr *ctr, int typ)
 		uns_set(gc, ctr->p, i + 1, UNS_POINTER, NULL);
 }
 
-static int get_type(Uns_ptr p)
+static void alloc_int(struct uns_ctr *ctr, long i)
+{
+	struct uns_ctr p = {0};
+
+	alloc_of_type(ctr, INTEGER);
+	p.p = uns_alloc(gc, sizeof(i), 0);
+
+	memcpy(p.p, &i, sizeof(i));
+	uns_set(gc, ctr->p, 1, UNS_POINTER, p.p);
+}
+
+static enum item_type get_type(Uns_ptr p)
 {
 	int typ;
 	void *innerp;
@@ -358,6 +381,41 @@ static void alloc_symbol_from_cstring(struct uns_ctr *ctr, const char *s, size_t
 	uns_root_remove(gc, &str);
 }
 
+static const char *get_string(struct uns_ctr *ctr)
+{
+	struct uns_ctr s = {0};
+
+	uns_root_add(gc, &s);
+	switch (get_type(ctr->p)) {
+	case STRING: case SYMBOL:
+		break;
+	default:
+		return NULL;
+	}
+
+	s.p = uns_get(gc, ctr->p, 1, NULL);
+	s.p = uns_string_cstring(gc, &s);
+	uns_root_remove(gc, &s);
+	return s.p;
+}
+
+static long get_int(struct uns_ctr *ctr)
+{
+	long r;
+
+	switch (get_type(ctr->p)) {
+	case INTEGER:
+		break;
+	default:
+		return 0;
+	}
+
+	memcpy(&r, uns_get(gc, ctr->p, 1, NULL), sizeof(r));
+	return r;
+}
+
+#define alloc_symbol_const(ctr, s) alloc_symbol_from_cstring(ctr, s, sizeof(s) - 1)
+
 enum expr_stack_state {
 	EXPR_STACK_INITIAL,
 	EXPR_STACK_QUOTELIKE,
@@ -384,13 +442,14 @@ static void expr_stack_push(struct uns_ctr *stack, struct uns_ctr *loc, enum exp
 	tmp.p = stack->p;
 	stack->p = uns_alloc_rec(gc, EXPR_FIELD_NUM, 0);
 	uns_set(gc, stack->p, EXPR_FIELD_NEXT, UNS_POINTER, tmp.p);
-	uns_root_remove(gc, &tmp);
 
 	uns_set(gc, stack->p, EXPR_FIELD_PTR, UNS_POINTER, loc->p);
 
 	tmp.p = uns_alloc(gc, sizeof(state), 0);
 	memcpy(tmp.p, &state, sizeof(state));
 	uns_set(gc, stack->p, EXPR_FIELD_STATE, UNS_POINTER, tmp.p);
+
+	uns_root_remove(gc, &tmp);
 }
 
 static enum expr_stack_state expr_stack_state(struct uns_ctr *stack)
@@ -513,10 +572,7 @@ static enum parser_return expr_parse(struct file *input, struct uns_ctr *expr)
 			store = 1;
 			break;
 		case T_INT:
-			alloc_of_type(expr, INTEGER);
-			loc.p = uns_alloc(gc, sizeof(tok.i), 0);
-			memcpy(loc.p, &tok.i, sizeof(tok.i));
-			uns_set(gc, expr->p, 1, UNS_POINTER, loc.p);
+			alloc_int(expr, tok.i);
 			store = 1;
 			break;
 		case T_FLOAT:
@@ -740,8 +796,7 @@ end:
 static void oom(Uns_GC gc_)
 {
 	(void)gc_;
-	printf("oom\n");
-	abort();
+	die("oom\n");
 }
 
 /* TODO: Make UNS_Lisp its own library and move this out. */
@@ -755,112 +810,826 @@ static void init(void)
 	alloc_of_type(&empty_list, EMPTY_LIST);
 }
 
-static void display(struct uns_ctr *ctr, long indent)
+/* Continuation passing style translation using a stack machine.
+ *
+ * There are two stacks: the argument stack and the read stack.
+ * At each step, the program reads the top of the read stack, which must
+ * be a recognized command. It then executes it.
+ *
+ * A command can modify the stacks in any way, although in most cases
+ * a command will modify the argument stack and push values to the read
+ * stack.
+ *
+ * Notation:
+ *    {arg-top} {read-top} => {new-arg-top} {new-read-top}
+ * The specified values in each stack are removed, and new values are put
+ * in their place. Values beyond those stack locations are not modified.
+ *
+ * Values in parentheses are LISP data. Values in angle brackets [ ] are
+ * meta-functions (they are modifications to LISP data implemented in C).
+ * All caps are LISP expressions, lowercase is a symbol. Commands are also
+ * symbols.
+ */
+
+static void gensym(struct uns_ctr *id)
+{
+	static unsigned long l = 0;
+	char buf[64];
+	int len;
+
+	len = sprintf(buf, "__%08lx", l);
+	alloc_symbol_from_cstring(id, buf, len);
+
+	l++;
+}
+
+static void cons(struct uns_ctr *into, struct uns_ctr *car, struct uns_ctr *cdr)
+{
+	alloc_of_type(into, CELL);
+	uns_set(gc, into->p, 1, UNS_POINTER, car->p);
+	uns_set(gc, into->p, 2, UNS_POINTER, cdr->p);
+}
+
+static void stack_push(struct uns_ctr *stack, struct uns_ctr *newval)
 {
 	struct uns_ctr tmp = {0};
-	long l;
-	double f;
 
-	if (!ctr->p) {
-		printf("<undefined>");
-		return;
+	uns_root_add(gc, &tmp);
+	tmp.p = stack->p;
+	cons(stack, newval, &tmp);
+	uns_root_remove(gc, &tmp);
+}
+
+static void stack_push_symbol(struct uns_ctr *stack, const char *s, size_t l)
+{
+	struct uns_ctr tmp = {0};
+
+	uns_root_add(gc, &tmp);
+	alloc_symbol_from_cstring(&tmp, s, l);
+	stack_push(stack, &tmp);
+	uns_root_remove(gc, &tmp);
+}
+#define stack_push_const(stack, s) stack_push_symbol(stack, s, sizeof(s) - 1)
+
+static int stack_pop(struct uns_ctr *stack, struct uns_ctr *into)
+{
+	if (!stack->p)
+		return 0;
+
+	switch (get_type(stack->p)) {
+	case EMPTY_LIST:
+		return 0;
+	case CELL:
+		break;
+	default:
+		die("Invalid type in CPS stack\n");
+	}
+	into->p = CAR(stack->p);
+	stack->p = CDR(stack->p);
+	return 1;
+}
+
+/* Initialize to {__toplevel EXPR} {__cps __return} */
+static void cps_init(struct uns_ctr *prevstack, struct uns_ctr *readstack,
+                     struct uns_ctr *expr)
+{
+	prevstack->p = empty_list.p;
+	readstack->p = empty_list.p;
+
+	stack_push_const(readstack, "return");
+	stack_push_const(readstack, "cps");
+
+	stack_push(prevstack, expr);
+	stack_push_const(prevstack, "__toplevel");
+}
+
+enum cps_return {
+	CPS_CONTINUE,
+	CPS_NOTHING_ON_STACK,
+	CPS_DATA_ON_READ_STACK,
+	CPS_STACK_UNDERFLOW,
+	CPS_CANNOT_CALL_TYPE,
+	CPS_QUOTE_UNDERFLOW,
+	CPS_QUOTE_OVERFLOW,
+	CPS_QUASIQUOTE_UNDERFLOW,
+	CPS_QUASIQUOTE_OVERFLOW,
+	CPS_LAMBDA_UNDERFLOW,
+	CPS_LAMBDA_OVERFLOW,
+	CPS_INVALID_LAMBDA_FORMAL,
+	CPS_DYNAMIC_WIND_UNDERFLOW,
+	CPS_DYNAMIC_WIND_SYMBOL,
+	CPS_DYNAMIC_WIND_OVERFLOW,
+	CPS_CALLCC_UNDERFLOW,
+	CPS_CALLCC_SYMBOL,
+	CPS_CALLCC_OVERFLOW,
+	CPS_IF_UNDERFLOW,
+	CPS_IF_OVERFLOW,
+	CPS_UNQUOTE_INVALID,
+	CPS_UNQUOTE_LIST_INVALID,
+	CPS_NULL_EXPR,
+	CPS_INVALID_CMD,
+
+	CPS_RETURN_LEN
+};
+
+static const char *cps_return_to_string[CPS_RETURN_LEN] = {
+	"CPS_CONTINUE",
+	"CPS_NOTHING_ON_STACK",
+	"CPS_DATA_ON_READ_STACK",
+	"CPS_STACK_UNDERFLOW",
+	"CPS_CANNOT_CALL_TYPE",
+	"CPS_QUOTE_UNDERFLOW",
+	"CPS_QUOTE_OVERFLOW",
+	"CPS_QUASIQUOTE_UNDERFLOW",
+	"CPS_QUASIQUOTE_OVERFLOW",
+	"CPS_LAMBDA_UNDERFLOW",
+	"CPS_LAMBDA_OVERFLOW",
+	"CPS_INVALID_LAMBDA_FORMAL",
+	"CPS_DYNAMIC_WIND_UNDERFLOW",
+	"CPS_DYNAMIC_WIND_SYMBOL",
+	"CPS_DYNAMIC_WIND_OVERFLOW",
+	"CPS_CALLCC_UNDERFLOW",
+	"CPS_CALLCC_SYMBOL",
+	"CPS_CALLCC_OVERFLOW",
+	"CPS_IF_UNDERFLOW",
+	"CPS_IF_OVERFLOW",
+	"CPS_UNQUOTE_INVALID",
+	"CPS_UNQUOTE_LIST_INVALID",
+	"CPS_INVALID_CMD",
+	"CPS_NULL_EXPR"
+};
+
+/* {K (quote QUOTED)} {cps} = {(-> QUOTED K)} */
+static enum cps_return cps_exec_quote(struct uns_ctr *prevstack,
+                                      struct uns_ctr *K,
+                                      struct uns_ctr *quoted,
+                                      struct uns_ctr *readstack
+                                     )
+{
+	struct uns_ctr wrapped = {0};
+
+	if (get_type(quoted->p) != CELL)
+		return CPS_QUOTE_UNDERFLOW;
+	if (get_type(CDR(quoted->p)) != EMPTY_LIST)
+		return CPS_QUOTE_OVERFLOW;
+
+	quoted->p = CAR(quoted->p);
+
+	uns_root_add(gc, &wrapped);
+	wrapped.p = empty_list.p;
+	stack_push(&wrapped, K);
+	stack_push(&wrapped, quoted);
+	stack_push_const(&wrapped, "__->");
+
+	stack_push(prevstack, &wrapped);
+
+	uns_root_remove(gc, &wrapped);
+	return CPS_CONTINUE;
+}
+
+/* Start quasiquotation:
+ * {K (quasiquote E)} {cps} = {K 1 E} {cps-quasiquote}
+ */
+
+static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack,
+                                           struct uns_ctr *K,
+                                           struct uns_ctr *quoted,
+                                           struct uns_ctr *readstack
+                                          )
+{
+	struct uns_ctr tmp = {0};
+	struct uns_ctr tmpint = {0};
+	const long i = 1;
+
+	if (get_type(quoted->p) != CELL)
+		return CPS_QUASIQUOTE_UNDERFLOW;
+	if (get_type(CDR(quoted->p)) != EMPTY_LIST)
+		return CPS_QUASIQUOTE_OVERFLOW;
+	quoted->p = CAR(quoted->p);
+
+	stack_push(prevstack, quoted);
+
+	uns_root_add(gc, &tmp);
+	alloc_of_type(&tmp, INTEGER);
+
+	uns_root_add(gc, &tmpint);
+	tmpint.p = uns_alloc(gc, sizeof(i), 0);
+	memcpy(tmpint.p, &i, sizeof(i));
+
+	uns_set(gc, tmp.p, 1, UNS_POINTER, tmpint.p);
+
+	stack_push(prevstack, &tmp);
+	stack_push(prevstack, K);
+
+	stack_push_const(readstack, "__quasiquote");
+
+	uns_root_remove(gc, &tmpint);
+	uns_root_remove(gc, &tmp);
+
+	return CPS_CONTINUE;
+}
+
+/* {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,
+                                       struct uns_ctr *rest,
+                                       struct uns_ctr *readstack
+                                      )
+{
+	struct uns_ctr tmpsym = {0};
+	struct uns_ctr tmp = {0};
+	enum cps_return r = CPS_CONTINUE;
+
+	if (get_type(rest->p) != CELL) {
+		r = CPS_LAMBDA_UNDERFLOW;
+		goto cleanup;
 	}
 
-	switch (get_type(ctr->p)) {
+	uns_root_add(gc, &tmpsym);
+	uns_root_add(gc, &tmp);
+
+	gensym(&tmpsym);
+
+	stack_push(prevstack, K);
+	stack_push(prevstack, &tmpsym);
+
+	/* (lambda l body)
+	            \ tmp.p */
+	tmp.p = CAR(rest->p);
+	switch (get_type(tmp.p)) {
+	case SYMBOL: case LISP_NULL:
+		break;
+	default:
+		r = CPS_INVALID_LAMBDA_FORMAL;
+		goto cleanup;
+	}
+
+	stack_push(prevstack, &tmp);
+
+	tmp.p = CDR(rest->p);
+	if (get_type(tmp.p) != CELL) {
+		r = CPS_LAMBDA_UNDERFLOW;
+		goto cleanup;
+	}
+
+	if (get_type(CDR(tmp.p)) != EMPTY_LIST) {
+		r = CPS_LAMBDA_OVERFLOW;
+		goto cleanup;
+	}
+
+	tmp.p = CAR(rest->p);
+	/* (lambda l body)
+	        tmp.p /
+	 */
+	stack_push(prevstack, &tmp);
+
+	stack_push(prevstack, &tmpsym);
+
+	stack_push_const(readstack, "cps-lambda");
+
+cleanup:
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &tmpsym);
+	return r;
+}
+
+/* {K (dynamic-wind before thunk after)} {cps} =
+     {(kappa/handle before after
+       (kappa k (@ thunk '() k))
+       K
+      )
+     } {}
+
+ * (kappa/handle before after KTHUNK K)
+ * pushes "before" and "after" to the list of dynamic-wind handlers
+ * for the continuation in KTHUNK. Every continuation constructed with
+ * kappa inside KTHUNK has these handlers appended, but continuations
+ * bound outside the dynamic-wind context do not have them appended.
+ * For instance, the "k" in the kappa form above does not have the
+ * dynamic-wind handlers added to it.
+ *
+ * The result from KTHUNK is passed to K, which does not have the
+ * handlers attached to it.
+ */
+static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
+                                             struct uns_ctr *K,
+                                             struct uns_ctr *lst,
+                                             struct uns_ctr *readstack
+                                            )
+{
+	struct uns_ctr expr = {0};
+	struct uns_ctr tmp1 = {0};
+	struct uns_ctr bound_k = {0};
+	struct uns_ctr before = {0};
+	struct uns_ctr thunk = {0};
+	struct uns_ctr after = {0};
+
+	if (get_type(lst->p) != CELL)
+		return CPS_DYNAMIC_WIND_UNDERFLOW;
+	before.p = CAR(lst->p);
+	if (get_type(before.p) != SYMBOL)
+		return CPS_DYNAMIC_WIND_SYMBOL;
+
+	lst->p = CDR(lst->p);
+	if (get_type(lst->p) != CELL)
+		return CPS_DYNAMIC_WIND_UNDERFLOW;
+	thunk.p = CAR(lst->p);
+	if (get_type(thunk.p) != SYMBOL)
+		return CPS_DYNAMIC_WIND_SYMBOL;
+
+	lst->p = CDR(lst->p);
+	if (get_type(lst->p) != CELL)
+		return CPS_DYNAMIC_WIND_UNDERFLOW;
+	after.p = CAR(lst->p);
+	if (get_type(after.p) != SYMBOL)
+		return CPS_DYNAMIC_WIND_SYMBOL;
+
+	if (get_type(CDR(lst->p)) != EMPTY_LIST)
+		return CPS_DYNAMIC_WIND_OVERFLOW;
+
+	uns_root_add(gc, &expr);
+	uns_root_add(gc, &tmp1);
+	uns_root_add(gc, &bound_k);
+	uns_root_add(gc, &before);
+	uns_root_add(gc, &thunk);
+	uns_root_add(gc, &after);
+
+	gensym(&bound_k);
+
+	expr.p = empty_list.p;
+	stack_push(&expr, &bound_k);
+	stack_push(&expr, &empty_list);
+	stack_push(&expr, &thunk);
+	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)) */
+
+	tmp1.p = expr.p;
+	expr.p = empty_list.p;
+	stack_push(&expr, K);
+	stack_push(&expr, &tmp1);
+	stack_push(&expr, &after);
+	stack_push(&expr, &before);
+	stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */
+
+	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &tmp1);
+	uns_root_remove(gc, &bound_k);
+	uns_root_remove(gc, &before);
+	uns_root_remove(gc, &thunk);
+	uns_root_remove(gc, &after);
+
+	return CPS_CONTINUE;
+}
+
+static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack,
+                                        struct uns_ctr *K,
+                                        struct uns_ctr *lst,
+                                        struct uns_ctr *readstack
+                                       )
+{
+	struct uns_ctr f = {0};
+	struct uns_ctr newk = {0};
+	struct uns_ctr tmp = {0};
+	struct uns_ctr expr = {0};
+
+	if (get_type(lst->p) != CELL)
+		return CPS_CALLCC_UNDERFLOW;
+	f.p = CAR(lst->p);
+	if (get_type(f.p) != SYMBOL)
+		return CPS_CALLCC_SYMBOL;
+
+	if (get_type(CDR(lst->p)) != EMPTY_LIST)
+		return CPS_CALLCC_OVERFLOW;
+
+	/* {(<- (kappa k (@ f k k)) K)} {} */
+
+	uns_root_add(gc, &tmp);
+	uns_root_add(gc, &expr);
+	uns_root_add(gc, &f);
+	uns_root_add(gc, &newk);
+
+	gensym(&newk);
+
+	expr.p = empty_list.p;
+	stack_push(&expr, &newk);
+	stack_push(&expr, &newk);
+	stack_push(&expr, &f);
+	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)) */
+
+	tmp.p = expr.p;
+	expr.p = empty_list.p;
+	stack_push(&expr, K);
+	stack_push(&expr, &tmp);
+	stack_push_const(&expr, "__<-"); /* (__<- (...) K) */
+
+	stack_push(prevstack, &expr);
+
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &f);
+	uns_root_remove(gc, &newk);
+	return CPS_CONTINUE;
+}
+
+/* {K (if E B1 B2} {cps} = {k B1 k B2 k K} {cps swap2 cps cps-if}
+ */
+static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
+                                   struct uns_ctr *K,
+                                   struct uns_ctr *lst,
+                                   struct uns_ctr *readstack
+                                  )
+{
+	struct uns_ctr newk = {0};
+	struct uns_ctr b1 = {0};
+	struct uns_ctr b2 = {0};
+
+	if (get_type(lst->p) != CELL)
+		return CPS_IF_UNDERFLOW;
+	b1.p = CAR(lst->p);
+	lst->p = CDR(lst->p);
+
+	if (get_type(lst->p) != CELL)
+		return CPS_IF_UNDERFLOW;
+	b2.p = CAR(lst->p);
+	if (get_type(CDR(lst->p)) != EMPTY_LIST)
+		return CPS_IF_OVERFLOW;
+
+	uns_root_add(gc, &newk);
+	uns_root_add(gc, &b1);
+	uns_root_add(gc, &b2);
+
+	stack_push(prevstack, K);
+	stack_push(prevstack, &newk);
+	stack_push(prevstack, &b2);
+	stack_push(prevstack, &newk);
+	stack_push(prevstack, &b1);
+	stack_push(prevstack, &newk);
+
+	stack_push_const(readstack, "cps-if");
+	stack_push_const(readstack, "cps");
+	stack_push_const(readstack, "swap2");
+	stack_push_const(readstack, "cps");
+
+	uns_root_remove(gc, &newk);
+	uns_root_remove(gc, &b1);
+	uns_root_remove(gc, &b2);
+
+	return CPS_CONTINUE;
+}
+
+/* {K (f . L)} {cps} = {(kappa l (@ f l K)) '() L} {cps-list} */
+static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
+                                      struct uns_ctr *K,
+                                      struct uns_ctr *E,
+                                      struct uns_ctr *readstack
+                                     )
+{
+	/* CAR(E.p) is the symbol */
+	struct uns_ctr tmp = {0};
+	struct uns_ctr expr = {0};
+	struct uns_ctr l = {0};
+
+	uns_root_add(gc, &expr);
+	uns_root_add(gc, &tmp);
+	uns_root_add(gc, &l);
+
+	gensym(&l);
+
+	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(prevstack, &expr);
+
+	stack_push_const(readstack, "cps-list");
+
+	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &l);
+	return CPS_CONTINUE;
+}
+
+/* {K (F . L)} {cps} = {(kappa l (@ f l K)) '() 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,
+                                               struct uns_ctr *readstack
+                                              )
+{
+	struct uns_ctr f = {0};
+	struct uns_ctr l = {0};
+	struct uns_ctr tmp = {0};
+	struct uns_ctr expr = {0};
+
+	uns_root_add(gc, &f);
+	uns_root_add(gc, &l);
+	uns_root_add(gc, &tmp);
+	uns_root_add(gc, &expr);
+	gensym(&f);
+	gensym(&l);
+
+	tmp.p = CAR(E->p);
+	stack_push(prevstack, &tmp);
+	stack_push(prevstack, &f);
+	tmp.p = CDR(E->p);
+	stack_push(prevstack, &tmp);
+	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, &l);
+	stack_push_const(&expr, "__K"); /* (__K l (f l K)) */
+	stack_push(prevstack, &expr);
+
+	stack_push_const(readstack, "cps-app");
+	stack_push_const(readstack, "cps-list");
+
+	uns_root_remove(gc, &f);
+	uns_root_remove(gc, &l);
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &expr);
+
+	return CPS_CONTINUE;
+}
+
+static enum cps_return cps_exec_cell(struct uns_ctr *prevstack,
+                                     struct uns_ctr *K,
+                                     struct uns_ctr *E,
+                                     struct uns_ctr *tmp,
+                                     struct uns_ctr *readstack
+                                    )
+{
+	const char *symb;
+	enum cps_return r;
+
+	tmp->p = CAR(E->p);
+
+	switch (get_type(tmp->p)) {
+	case INTEGER: case FLOAT: case STRING: case EMPTY_LIST:
+	case LISP_NULL:
+		r = CPS_CANNOT_CALL_TYPE;
+		break;
+	case SYMBOL:
+		symb = get_string(tmp);
+		if (strcmp(symb, "quote") == 0) {
+			tmp->p = CDR(E->p);
+			r = cps_exec_quote(prevstack, K, tmp, readstack);
+		} else if (strcmp(symb, "quasiquote") == 0) {
+			tmp->p = CDR(E->p);
+			r = cps_exec_quasiquote(prevstack, K, tmp, readstack);
+		} else if (strcmp(symb, "__lambda") == 0) {
+			tmp->p = CDR(E->p);
+			r = cps_exec_lambda(prevstack, K, tmp, readstack);
+		} else if (strcmp(symb, "__call/cc") == 0) {
+			/* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */
+			tmp->p = CDR(E->p);
+			r = cps_exec_call_cc(prevstack, K, tmp, readstack);
+		} else if (strcmp(symb, "__dynamic-wind") == 0) {
+			tmp->p = CDR(E->p);
+			r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack);
+		} else if (strcmp(symb, "unquote") == 0) {
+			r = CPS_UNQUOTE_INVALID;
+		} else if (strcmp(symb, "unquote-list") == 0) {
+			r = CPS_UNQUOTE_LIST_INVALID;
+		} else if (strcmp(symb, "if") == 0) {
+			 tmp->p = CDR(E->p);
+			 r = cps_exec_if(prevstack, K, tmp, readstack);
+		} else {
+			r = cps_exec_fcall(prevstack, K, E, readstack);
+		}
+		break;
 	case CELL:
-		uns_root_add(gc, &tmp);
-
-		printf("(");
-		tmp.p = uns_get(gc, ctr->p, 1, NULL);
-		display(&tmp, indent);
-
-		ctr->p = uns_get(gc, ctr->p, 2, NULL);
-		while (get_type(ctr->p) == CELL) {
-			tmp.p = uns_get(gc, ctr->p, 1, NULL);
-			if (get_type(tmp.p) == CELL) {
-				printf("\n");
-				for (l = 0; l < indent; l++)
-					printf(" ");
-				display(&tmp, indent + 1);
-			} else {
+		r = cps_exec_compound_fcall(prevstack, K, E, readstack);
+	}
+
+	return r;
+}
+
+/* {K E} {cps} */
+static enum cps_return cps_exec(struct uns_ctr *prevstack,
+                                struct uns_ctr *readstack)
+{
+	struct uns_ctr K = {0};
+	struct uns_ctr E = {0};
+	struct uns_ctr tmp = {0};
+	enum cps_return r = CPS_CONTINUE;
+
+	tmp.p = empty_list.p;
+
+	uns_root_add(gc, &K);
+	uns_root_add(gc, &E);
+	uns_root_add(gc, &tmp);
+
+	if (!stack_pop(prevstack, &K)) {
+		r = CPS_STACK_UNDERFLOW;
+		goto end;
+	}
+	if (!stack_pop(prevstack, &E)) {
+		r = CPS_STACK_UNDERFLOW;
+		goto end;
+	}
+
+	switch (get_type(E.p)) {
+	/* {(-> atom K)} {} */
+	case INTEGER: case STRING: case SYMBOL: case FLOAT:
+	case EMPTY_LIST:
+		stack_push(&tmp, &K);
+		stack_push(&tmp, &E);
+		stack_push_const(&tmp, "__->");
+		stack_push(prevstack, &tmp);
+		break;
+	case CELL:
+		r = cps_exec_cell(prevstack, &K, &E, &tmp, readstack);
+		break;
+	case LISP_NULL:
+		r = CPS_NULL_EXPR;
+		break;
+	}
+
+end:
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &E);
+	uns_root_remove(gc, &K);
+
+	return r;
+}
+
+static enum cps_return cps(struct uns_ctr *prevstack,
+                           struct uns_ctr *readstack)
+{
+	struct uns_ctr top = {0};
+	const char *cmd;
+	enum cps_return r = CPS_CONTINUE;
+
+	uns_root_add(gc, &top);
+
+	if (!stack_pop(readstack, &top)) {
+		r = CPS_NOTHING_ON_STACK;
+		goto end;
+	}
+
+	if (get_type(top.p) != SYMBOL) {
+		r = CPS_DATA_ON_READ_STACK;
+		goto end;
+	}
+	cmd = get_string(&top);
+
+	if (strcmp(cmd, "cps") == 0) {
+		r = cps_exec(prevstack, readstack);
+	} else {
+		r = CPS_INVALID_CMD;
+	}
+
+end:
+	uns_root_remove(gc, &top);
+	return r;
+}
+
+static void display(struct uns_ctr *ctr)
+{
+	long indent = 0;
+	long list_part = 0;
+	int add_space = 0;
+	int end_list_seq = 0;
+	struct uns_ctr stack = {0};
+	struct uns_ctr top = {0};
+	struct uns_ctr ival = {0};
+	struct uns_ctr tmp = {0};
+	struct uns_ctr exprstore = {0};
+	long l;
+	double f;
+
+#define SPC (add_space ? " " : "")
+
+	uns_root_add(gc, &stack);
+	uns_root_add(gc, &top);
+	uns_root_add(gc, &ival);
+	uns_root_add(gc, &tmp);
+	uns_root_add(gc, &exprstore);
+
+	stack.p = empty_list.p;
+	alloc_int(&ival, 0);
+	cons(&top, &ival, ctr); /* (0 . expr) */
+	stack_push(&stack, &top);
+
+	while (stack_pop(&stack, &top)) {
+		ival.p = CAR(top.p);
+		list_part = get_int(&ival);
+		top.p = CDR(top.p);
+
+		if (get_type(top.p) != EMPTY_LIST)
+			end_list_seq = 0;
+
+		if (!list_part && end_list_seq) {
+			printf("\n");
+			for (l = 0; l < indent; l++) {
 				printf(" ");
-				display(&tmp, indent);
 			}
-
-			ctr->p = uns_get(gc, ctr->p, 2, NULL);
+			end_list_seq = 0;
+			add_space = 1;
 		}
 
-		switch (get_type(ctr->p)) {
+		switch(get_type(top.p)) {
+		case INTEGER:
+			memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long));
+			printf("%s%ld", SPC, l);
+			break;
+		case FLOAT:
+			memcpy(&f, uns_get(gc, top.p, 1, NULL), sizeof(double));
+			printf("%s%f", SPC, f);
+			break;
+		case STRING:
+			tmp.p = uns_get(gc, top.p, 1, NULL);
+			uns_root_add(gc, &tmp);
+			printf("%s\"%s\"", SPC, uns_string_cstring(gc, &tmp));
+			uns_root_remove(gc, &tmp);
+			break;
+		case SYMBOL:
+			tmp.p = uns_get(gc, top.p, 1, NULL);
+			printf("%s%s", SPC, uns_string_cstring(gc, &tmp));
+			break;
 		case EMPTY_LIST:
-			printf(")");
+			if (list_part) {
+				printf(")");
+				indent--;
+				end_list_seq = 1;
+			} else {
+				printf("%s'()", SPC);
+				end_list_seq = 0;
+			}
 			break;
-		default:
-			printf(" . ");
-			display(ctr, indent);
-			printf(")");
+		case LISP_NULL:
+			printf("<undefined>\n");
+			break;
+		case CELL:
+			alloc_int(&ival, 1);
+			exprstore.p = CDR(top.p);
+			cons(&tmp, &ival, &exprstore);
+			stack_push(&stack, &tmp);
+
+			alloc_int(&ival, 0);
+			exprstore.p = CAR(top.p);
+			cons(&tmp, &ival, &exprstore);
+			stack_push(&stack, &tmp);
+
+			if (!list_part) {
+				indent++;
+				if (add_space) {
+					printf("\n");
+					for (l = 0; l < indent; l++) {
+						printf(" ");
+					}
+					add_space = 0;
+				}
+				printf("(");
+			}
 			break;
 		}
 
-		uns_root_remove(gc, &tmp);
-		return;
-	case INTEGER:
-		memcpy(&l, uns_get(gc, ctr->p, 1, NULL), sizeof(long));
-		printf("%ld", l);
-		return;
-	case FLOAT:
-		memcpy(&f, uns_get(gc, ctr->p, 1, NULL), sizeof(double));
-		printf("%f", f);
-		return;
-	case STRING:
-		tmp.p = uns_get(gc, ctr->p, 1, NULL);
-		uns_root_add(gc, &tmp);
-		printf("\"%s\"", uns_string_cstring(gc, &tmp));
-		uns_root_remove(gc, &tmp);
-		return;
-	case SYMBOL:
-		tmp.p = uns_get(gc, ctr->p, 1, NULL);
-		uns_root_add(gc, &tmp);
-		printf("%s", uns_string_cstring(gc, &tmp));
-		uns_root_remove(gc, &tmp);
-		return;
-	case EMPTY_LIST:
-		printf("'()");
-		return;
-	default:
-		abort();
+		if (get_type(top.p) != CELL)
+			add_space = 1;
 	}
-}
 
-/* Contination passing style.
- * Continuation passing IR uses explicit statements instead of
- * shorthand (i.e. (__pass K atom) instead of (K atom)).
- *
- * CPS primitives:
- * (__pass k e): Pass e to continuation k. e must be an atom.
- * (__apply f l k): Pass the argument list "l" to "f", and pass
- *   the result to "k". "f" must be a "__klambda".
- * (__konstruct e body): Construct a continuation that takes a
- *   single argument. This is shortened to "\e body" below.
- * (__klambda l k body): Constructs a function that takes a single
- *   value along with a continuation.
- * (__primitive-> args...) The primitive, but the last argument is a
- *   continuation.
-
- * cps{atom, K} = (__pass K atom)
- * cps{(__lambda l E), K} = (__pass K (__klambda l k cps{E,k}))
-
- * cps{(F A1 ... AN), K} =
- *   cps{F, \f cps_list{'(), (A1 ... AN), \l (__apply f l K)}}
- * cps_list{L, '(), K} = (__pass K L)
- * cps_list{L, (A . B), K} =
- *   cps{A, \a cps_list{append{L,a}, B, K}}
-
- * cps{(if E B1 B2), K} =
- *   cps{E, \e (__if* e (\K' cps{B1,K'}) (\K' cps{B1,K'}) K)}
- *
- * cps{(__define symb E}, K} = cps{E, \e (__define-> symb e K)}
- * cps{(set! symb E), K} = cps{E, \e (__set!-> symb e K)}
- */
+	uns_root_remove(gc, &stack);
+	uns_root_remove(gc, &top);
+	uns_root_remove(gc, &ival);
+	uns_root_remove(gc, &tmp);
+	uns_root_remove(gc, &exprstore);
+	printf("\n");
+}
 
 static void error(struct location *loc, const char *emsg)
 {
@@ -871,20 +1640,24 @@ static void error(struct location *loc, const char *emsg)
 int main(void)
 {
 	struct uns_ctr expr = {0};
+	struct uns_ctr prevstack = {0};
+	struct uns_ctr readstack = {0};
 	struct file input = {0};
 	input.loc.line = 1;
 
 	init();
 	uns_root_add(gc, &expr);
+	uns_root_add(gc, &prevstack);
+	uns_root_add(gc, &readstack);
 	input.f = stdin;
 
 	while (!feof(input.f)) {
 		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, 1);
-			printf("\n");
+			display(&expr);
 			break;
 		case EXPR_PARSE_INCOMPLETE:
 			error(&input.loc, "EOF before expression was finished");
@@ -911,11 +1684,22 @@ int main(void)
 			break;
 		case EXPR_PARSE_EOF:
 			error(&input.loc, "EOF\n");
-			break;
+			goto cleanup;
 		}
+
+		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");
 	}
 
+cleanup:
 	uns_root_remove(gc, &expr);
+	uns_root_remove(gc, &prevstack);
+	uns_root_remove(gc, &readstack);
 	uns_deinit(gc);
 	return 0;
 }
diff --git a/examples/lisp/uns_lisp_cheney_c89.c b/examples/lisp/uns_lisp_cheney_c89.c
index 96b49a9..a1f770c 100644
--- a/examples/lisp/uns_lisp_cheney_c89.c
+++ b/examples/lisp/uns_lisp_cheney_c89.c
@@ -48,6 +48,7 @@ static void after_gc(Uns_GC gc, struct uns_cheney_c89_statistics *stats)
 Uns_GC uns_lisp_gc_init(void)
 {
 	Uns_GC gc = malloc(uns_gc_size);
+	uns_gc_zero(gc);
 	if (!uns_cheney_c89_init(gc, 512)) {
 		fprintf(stderr, "Error initializing GC\n");
 		exit(1);