universalservice/examples/lisp/uns_lisp.c

/* Copyright (c) 2024, Peter McGoron
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 * 1) Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2) Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 */

#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,
	RPAREN,
	QUOTE,
	QUASIQUOTE,
	UNQUOTE,
	UNQUOTE_LIST,
	T_IDENT,
	T_INT,
	T_FLOAT,
	T_STRING,
	T_DOT,
	TOKEN_NUM
};

static const char *token2string_repr[TOKEN_NUM] = {
	"'EOF",
	"(",
	")",
	"quote",
	"quasiquote",
	"unquote",
	"unquote-list",
	"'ident",
	"'number",
	"'float",
	"'string-tok",
	"'dot"
};

struct location {
	unsigned long line;
	unsigned long offset;
};

struct file {
	FILE *f;
	struct location loc;
};

struct token {
	enum token_type typ;
	struct uns_ctr dat;

	double f;
	long i;
};

static int is_ws(int c)
{
	return c == '\n' || c == '\t' || c == '\r' || c == '\v' || c == ' ';
}

static int get(struct file *f)
{
	int c = getc(f->f);

	if (c == '\n') {
		f->loc.line++;
		f->loc.offset = 0;
	} else {
		f->loc.offset += 1;
	}

	return c;
}

static void unget(int c, struct file *f)
{
	ungetc(c, f->f);
}

static int get_skipws(struct file *input)
{
	int c;

	for (;;) {
		c = get(input);
		if (c == ';') {
			do { c = get(input); } while (c != '\n');
			unget(c, input);
			continue;
		}

		if (is_ws(c))
			continue;
		return c;
	}
}

static void tok_string(struct file *input, struct token *tok)
{
	int c;

	tok->typ = T_STRING;
	uns_string_alloc(gc, &tok->dat, 32);
	for (;;) {
		c = get(input);
		switch (c) {
		case '\\':
			c = get(input);
			switch (c) {
			case ' ': case '\t': case '\r': case '\n': case '\v':
				do {
					c = get(input);
				} while (is_ws(c));
				unget(c, input);
				continue;
			case 'r':
				uns_string_append_char(gc,  &tok->dat, '\r');
				continue;
			case 'n':
				uns_string_append_char(gc,  &tok->dat, '\n');
				continue;
			case 'v':
				uns_string_append_char(gc,  &tok->dat, '\v');
				continue;
			case 't':
				uns_string_append_char(gc,  &tok->dat, '\t');
				continue;
			case '"':
				uns_string_append_char(gc,  &tok->dat, '"');
				continue;
			default:
				uns_string_append_char(gc, &tok->dat, '\\');
				uns_string_append_char(gc, &tok->dat, c);
			}
		case '"': /* " */
			return;
		}
	}
}

static int tonum(int c)
{
	switch (c) {
	case '0': case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
		return c - '0';
	default:
		return -1;
	}
}

static void tok_num(struct file *input, struct token *tok, int c)
{
	int is_float = 0;

	uns_string_alloc(gc, &tok->dat, 32);
	do {
		if (c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+')
			is_float = 1;
		uns_string_append_char(gc, &tok->dat, c);
		c = get(input);
	} while (tonum(c) >= 0 || c == '.' || c == 'e' || c == 'E' || c == '-' || c == '+');
	unget(c, input);

	if (is_float) {
		tok->typ = T_FLOAT;
		tok->f = strtod(uns_string_cstring(gc, &tok->dat), NULL);
	} else {
		tok->typ = T_INT;
		tok->i = strtol(uns_string_cstring(gc, &tok->dat), NULL, 10);
	}
		
	tok->dat.p = NULL;
}

static int part_of_ident(int c)
{
	return !is_ws(c) && c != '(' && c != ')' && c != '`'
	    && c != '\'' && c != '\\' && c != '\"' && c != ','
	    && c != ';';
}

static void tok_ident(struct file *input, struct token *tok, int c)
{
	tok->typ = T_IDENT;

	uns_string_alloc(gc, &tok->dat, 32);
	do {
		uns_string_append_char(gc, &tok->dat, c);
		c = get(input);
	} while (part_of_ident(c));
	unget(c, input);
}

static void tokenize(struct file *input, struct token *tok)
{
	int c = get_skipws(input);
	int c2;

	tok->dat.p = NULL;

	switch (c) {
	case EOF:
		tok->typ = T_EOF;
		return;
	case '(':
		tok->typ = LPAREN;
		return;
	case ')':
		tok->typ = RPAREN;
		return;
	case '\'':
		tok->typ = QUOTE;
		return;
	case '`':
		tok->typ = QUASIQUOTE;
		return;
	case ',':
		c = get(input);
		if (c == '@') {
			tok->typ = UNQUOTE_LIST;
		} else {
			unget(c, input);
			tok->typ = UNQUOTE;
		}
		return;
	case '"':
		tok_string(input, tok);
		return;
		tok->typ = T_STRING;
		return;
	case '+': case '-':
		c2 = get(input);
		unget(c2, input);
		if (tonum(c2) >= 0) {
			tok_num(input, tok, c);
			return;
		}
		/* FALLTHROUGH */
	default:
		if (c == '.') {
			c2 = get(input);
			if (tonum(c2) >= 0) {
				unget(c2, input);
				tok_num(input, tok, c);
			} else if (part_of_ident(c2)) {
				unget(c2, input);
				tok_ident(input, tok, c);
			} else {
				tok->typ = T_DOT;
			}
		} else if (tonum(c) >= 0) {
			tok_num(input, tok, c);
		} else {
			tok_ident(input, tok, c);
		}
		return;
	}
}

enum item_type {
	CELL,
	INTEGER,
	FLOAT,
	STRING,
	SYMBOL,
	EMPTY_LIST,
	LISP_NULL
};

/* TODO: if the allocator allows for weak references, do a lookup of
 * the symbol in the tree, and if it exists, use that instead of the
 * token.
 *
 * This check should always be ignored on collectors without weak
 * references.
 */
static void alloc_of_type(struct uns_ctr *ctr, int typ)
{
	void *p;
	int fields;
	int i;

	switch (typ) {
	case CELL: 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: die("Invalid type %d\n", typ);
	}

	ctr->p = uns_alloc_rec(gc, fields + 1, 0);
	p = uns_alloc(gc, sizeof(int), 0);
	memcpy(p, &typ, sizeof(int));
	uns_set(gc, ctr->p, 0, UNS_POINTER, p);

	for (i = 0; i < fields; i++)
		uns_set(gc, ctr->p, i + 1, UNS_POINTER, NULL);
}

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;

	if (!p)
		return LISP_NULL;
	innerp = uns_get(gc, p, 0, NULL);

	memcpy(&typ, innerp, sizeof(int));
	return typ;
}

static void alloc_symbol_from_cstring(struct uns_ctr *ctr, const char *s, size_t slen)
{
	struct uns_ctr str = {0};

	uns_root_add(gc, &str);
	uns_string_alloc(gc, &str, slen);
	uns_string_append_bytes(gc, &str, s, slen);

	alloc_of_type(ctr, SYMBOL);
	uns_set(gc, ctr->p, 1, UNS_POINTER, str.p);

	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,
	EXPR_STACK_SURROUND_OTHER,
	EXPR_STACK_START_LIST,
	EXPR_STACK_IN_LIST,
	EXPR_STACK_IMPROPER_LIST,
	EXPR_STACK_IMPROPER_LIST_END,
	EXPR_STACK_INVALID
};

enum expr_stack_fields {
	EXPR_FIELD_NEXT,
	EXPR_FIELD_PTR,
	EXPR_FIELD_STATE,
	EXPR_FIELD_NUM
};

static void expr_stack_push(struct uns_ctr *stack, struct uns_ctr *loc, enum expr_stack_state state)
{
	struct uns_ctr tmp = {0};

	uns_root_add(gc, &tmp);
	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_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)
{
	enum expr_stack_state r;
	if (!stack->p)
		return EXPR_STACK_INVALID;
	memcpy(&r, uns_get(gc, stack->p, EXPR_FIELD_STATE, NULL),
	       sizeof(r));
	return r;
}

static void expr_stack_change_state(struct uns_ctr *stack, enum expr_stack_state newst)
{
	memcpy(uns_get(gc, stack->p, EXPR_FIELD_STATE, NULL),
	       &newst,
	       sizeof(newst));
}

static void expr_stack_ctr(struct uns_ctr *stack, struct uns_ctr *loc)
{
	loc->p = uns_get(gc, stack->p, EXPR_FIELD_PTR, NULL);
}

static int expr_stack_pop(struct uns_ctr *stack)
{
	if (!stack->p)
		return 0;
	stack->p = uns_get(gc, stack->p, EXPR_FIELD_NEXT, NULL);
	return 1;
}

enum parser_return {
	EXPR_PARSE_OK,
	EXPR_PARSE_EOF,
	EXPR_PARSE_INCOMPLETE,
	EXPR_PARSE_EXCESS_RPAREN,
	EXPR_PARSE_INVALID_EMPTY_LIST,
	EXPR_PARSE_IMPROPER_LIST_OVERFLOW,
	EXPR_PARSE_BAD_IMPROPER_LIST,
	EXPR_PARSE_BAD_STACK_START,
	EXPR_PARSE_BAD_QUOTE,
	EXPR_PARSE_INTERNAL_ERROR
};

static int tok_to_type(enum token_type tokt)
{
	switch (tokt) {
	case T_IDENT: return SYMBOL;
	case T_STRING: return STRING;
	default: return -1;
	}
}

/* Parse expressions using an explicit stack.
 * This is feasible to to hand-written and has the advantage that error
 * recovery is much easier than recursion (implicit stack).
 *
 * The stack consists of a LIFO:
 *      [previous value][container][parser state]
 *
 * The implementation stores containers on the stack and when a container
 * is complete or an atom is read, it is stored in "expr" and the stack
 * is modified.
 */
static enum parser_return expr_parse(struct file *input, struct uns_ctr *expr)
{
	struct uns_ctr stack = {0};
	struct uns_ctr loc = {0};
	struct uns_ctr new_cell = {0};
	struct token tok = {0};
	int store = 0;
	enum parser_return r = EXPR_PARSE_OK;

	uns_root_add(gc, &stack);
	uns_root_add(gc, &loc);
	uns_root_add(gc, &tok.dat);
	uns_root_add(gc, &new_cell);

	/* Allocate expr->p to be a single pointer. */
	expr->p = uns_alloc_rec(gc, 1, 0);

	/* Initialize the stack with the final result. */
	expr_stack_push(&stack, expr, EXPR_STACK_INITIAL);

	while (stack.p) {
		tokenize(input, &tok);

		switch (tok.typ) {
		case LPAREN:
			/* Push a new cell onto the stack and parse it later. */
			alloc_of_type(expr, CELL);
			expr_stack_push(&stack, expr, EXPR_STACK_START_LIST);
			break;
		case QUOTE: case QUASIQUOTE: case UNQUOTE: case UNQUOTE_LIST:
			/* push (token-name <undefined>) onto the stack, and have
			 * it point to the first cell.
			 */
			alloc_of_type(&loc, CELL);
			alloc_symbol_from_cstring(expr, token2string_repr[tok.typ],
			                          strlen(token2string_repr[tok.typ]));
			uns_set(gc, loc.p, 1, UNS_POINTER, expr->p);

			alloc_of_type(expr, CELL);
			uns_set(gc, loc.p, 2, UNS_POINTER, expr->p);
			uns_set(gc, expr->p, 2, UNS_POINTER, empty_list.p);

			if (tok.typ == QUOTE || tok.typ == QUASIQUOTE)
				expr_stack_push(&stack, &loc, EXPR_STACK_QUOTELIKE);
			else
				expr_stack_push(&stack, &loc, EXPR_STACK_SURROUND_OTHER);
			break;

		/* All atoms are allocated into "expr" and will be stored in the
		 * container after the switch.
		 */
		case T_IDENT: case T_STRING:
			alloc_of_type(expr, tok_to_type(tok.typ));
			uns_set(gc, expr->p, 1, UNS_POINTER, tok.dat.p);
			store = 1;
			break;
		case T_INT:
			alloc_int(expr, tok.i);
			store = 1;
			break;
		case T_FLOAT:
			alloc_of_type(expr, FLOAT);
			loc.p = uns_alloc(gc, sizeof(tok.f), 0);
			memcpy(loc.p, &tok.f, sizeof(tok.f));
			uns_set(gc, expr->p, 1, UNS_POINTER, loc.p);
			store = 1;
			break;

		case RPAREN:
			switch (expr_stack_state(&stack)) {
			case EXPR_STACK_START_LIST:
				/* Empty list found. Pop the cell and discard it.
				 * If we are not in a "surround" state, report error.
				 * Replace the surround state with an empty list.
				 */
				expr_stack_pop(&stack);
				if (!stack.p) {
					r = EXPR_PARSE_INTERNAL_ERROR;
					goto end;
				}

				if (expr_stack_state(&stack) != EXPR_STACK_QUOTELIKE) {
					r = EXPR_PARSE_INVALID_EMPTY_LIST;
					goto end;
				}

				/* Discard quote/quasiquote and store the empty list instead. */
				if (!expr_stack_pop(&stack)) {
					r = EXPR_PARSE_INTERNAL_ERROR;
					goto end;
				}

				expr->p = empty_list.p;
				store = 1;
				break;
			case EXPR_STACK_IN_LIST:
				/* In a list, there are two things on the stack:
				 * first cell and last cell.
				 * Place the empty list in the cdr of the last cell,
				 * and then discard the last cell. Put the first cell into expr
				 * and store it in the container in the stack before it.
				 */
				 expr_stack_ctr(&stack, &loc);
				 if (get_type(loc.p) != CELL) {
				 	r = EXPR_PARSE_INTERNAL_ERROR;
				 	goto end;
				 }

				uns_set(gc, loc.p, 2, UNS_POINTER, empty_list.p);
				/* FALLTHROUGH */
			case EXPR_STACK_IMPROPER_LIST_END:
				/* CDR of the list has been filled. Pop the last cell. */
				expr_stack_pop(&stack);
				if (!stack.p) {
					r = EXPR_PARSE_INTERNAL_ERROR;
					goto end;
				}

				/* Put the first cell in expr, and read it into the next item
				 * of the stack.
				 */
				expr_stack_ctr(&stack, expr);
				expr_stack_pop(&stack);
				store = 1;
				break;
			case EXPR_STACK_INITIAL:
				/* Expression is not balanced. */
				r = EXPR_PARSE_EXCESS_RPAREN;
				goto end;
			case EXPR_STACK_IMPROPER_LIST:
				/* (values .) is an invalid expression. */
				r = EXPR_PARSE_BAD_IMPROPER_LIST;
				goto end;
			case EXPR_STACK_QUOTELIKE: case EXPR_STACK_SURROUND_OTHER:
				/* ,) ') etc are invalid */
				r = EXPR_PARSE_BAD_QUOTE;
				goto end;
			case EXPR_STACK_INVALID:
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}
			break;
		case T_DOT:
			if (expr_stack_state(&stack) != EXPR_STACK_IN_LIST) {
				r = EXPR_PARSE_BAD_IMPROPER_LIST;
				goto end;
			}

			expr_stack_change_state(&stack, EXPR_STACK_IMPROPER_LIST);
			break;
		case T_EOF:
			/* If EOF is encountered in the middle of an expression, repor
			 * that. Otherwise, the parser reads nothing.
			 */
			if (expr_stack_state(&stack) != EXPR_STACK_INITIAL) {
				r = EXPR_PARSE_INCOMPLETE;
				goto end;
			}
			r = EXPR_PARSE_EOF;
			goto end;
		case TOKEN_NUM:
			r = EXPR_PARSE_INTERNAL_ERROR;
			goto end;
		}

		/* If store is true, that means "expr" contains a value to
		 * be placed into the container at the top of the stack.
		 *
		 * This is a loop because some cases need to cascade values up the
		 * stack without acting on a token. When the loop stops, further
		 * action requires a new token to be read.
		 */
		while (store) switch (expr_stack_state(&stack)) {
		case EXPR_STACK_INVALID:
			r = EXPR_PARSE_INTERNAL_ERROR;
			goto end;
		case EXPR_STACK_START_LIST:
			/* The current thing on the stack is the first part of the
			 * list. Add the expression to car of the cell, and add
			 * push a pointer to the cell. This is the last cell in
			 * the list.
			 */
			expr_stack_ctr(&stack, &loc);
			if (get_type(loc.p) != CELL) {
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}

			uns_set(gc, loc.p, 1, UNS_POINTER, expr->p);
			expr_stack_push(&stack, &loc, EXPR_STACK_IN_LIST);
			store = 0;
			break;
		case EXPR_STACK_IN_LIST:
			/* The pointer on the top of the stack is the end of the
			 * list. Add a new list to it's cdr, and put expr into
			 * the car of the new end of the list.
			 */
			expr_stack_ctr(&stack, &loc);
			if (get_type(loc.p) != CELL) {
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}

			alloc_of_type(&new_cell, CELL);
			uns_set(gc, loc.p, 2, UNS_POINTER, new_cell.p);
			uns_set(gc, new_cell.p, 1, UNS_POINTER, expr->p);
			expr_stack_pop(&stack);
			expr_stack_push(&stack, &new_cell, EXPR_STACK_IN_LIST);
			store = 0;
			break;
		case EXPR_STACK_IMPROPER_LIST:
			/* Add the expression to the cdr of the last element.
			 * Set the state to expect the end of an improper list.
			 */
			expr_stack_ctr(&stack, &loc);
			uns_set(gc, loc.p, 2, UNS_POINTER, expr->p);
			if (get_type(loc.p) != CELL) {
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}

			expr_stack_change_state(&stack, EXPR_STACK_IMPROPER_LIST_END);
			store = 0;
			break;
		case EXPR_STACK_IMPROPER_LIST_END:
			r = EXPR_PARSE_IMPROPER_LIST_OVERFLOW;
			goto end;
		case EXPR_STACK_QUOTELIKE: case EXPR_STACK_SURROUND_OTHER:
			/* Expression at the top of the stack is
			 *    (surrouding-thing <undefined>)
			 * Replace (car (cdr (top-of-stack)) with expr.
			 */
			expr_stack_ctr(&stack, &loc);
			if (get_type(loc.p) != CELL) {
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}

			loc.p = uns_get(gc, loc.p, 2, NULL);
			if (get_type(loc.p) != CELL) {
				r = EXPR_PARSE_INTERNAL_ERROR;
				goto end;
			}

			uns_set(gc, loc.p, 1, UNS_POINTER, expr->p);

			/* Get the head of the quoted value again. */
			expr_stack_ctr(&stack, expr);
			expr_stack_pop(&stack);

			/* This value needs to be stored somewhere. Continue looping. */
			store = 1;
			break;
		case EXPR_STACK_INITIAL:
			/* Finished parsing an expression at toplevel. */
			expr_stack_ctr(&stack, &loc);
			uns_set(gc, loc.p, 0, UNS_POINTER, expr->p);

			/* Prepare for return. */
			expr->p = loc.p;
			expr_stack_pop(&stack);
			if (stack.p) {
				r = EXPR_PARSE_BAD_STACK_START;
				goto end;
			}
			store = 0;
			break;
		}
	}

end:
	uns_root_remove(gc, &stack);
	uns_root_remove(gc, &loc);
	uns_root_remove(gc, &tok.dat);
	uns_root_remove(gc, &new_cell);
	return r;
}

static void oom(Uns_GC gc_)
{
	(void)gc_;
	die("oom\n");
}

/* TODO: Make UNS_Lisp its own library and move this out. */
extern Uns_GC uns_lisp_gc_init(void);
static void init(void)
{
	gc = uns_lisp_gc_init();

	uns_set_oom(gc, oom);
	uns_root_add(gc, &empty_list);
	alloc_of_type(&empty_list, EMPTY_LIST);
}

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

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

	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:
		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(" ");
			}
			end_list_seq = 0;
			add_space = 1;
		}

		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:
			if (list_part) {
				printf(")");
				indent--;
				end_list_seq = 1;
			} else {
				printf("%s'()", SPC);
				end_list_seq = 0;
			}
			break;
		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;
		}

		if (get_type(top.p) != CELL)
			add_space = 1;
	}

	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)
{
	fprintf(stderr, "%ld:%ld: ", loc->line, loc->offset);
	fprintf(stderr, "%s\n", 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);
			break;
		case EXPR_PARSE_INCOMPLETE:
			error(&input.loc, "EOF before expression was finished");
			break;
		case EXPR_PARSE_EXCESS_RPAREN:
			error(&input.loc, "Unbalanced parentheses");
			break;
		case EXPR_PARSE_INVALID_EMPTY_LIST:
			error(&input.loc, "Invalid syntax for empty list (either '() or `'())");
			break;
		case EXPR_PARSE_BAD_QUOTE:
			error(&input.loc, "Invalid syntax for quotes/unquotes");
			break;
		case EXPR_PARSE_IMPROPER_LIST_OVERFLOW:
			error(&input.loc, "too many values at end of improper list (must be exactly one)");
		case EXPR_PARSE_BAD_IMPROPER_LIST:
			error(&input.loc, "Bad syntax for improper list (must be (value . value))");
			break;
		case EXPR_PARSE_INTERNAL_ERROR:
			error(&input.loc, "Bug in implementation\n");
			break;
		case EXPR_PARSE_BAD_STACK_START:
			error(&input.loc, "Bug: bottom of stack not correct\n");
			break;
		case EXPR_PARSE_EOF:
			error(&input.loc, "EOF\n");
			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;
}