/* 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 <string.h>
#include <stdlib.h>
#include "uns.h"
#include "examples/string/uns_string.h"

static Uns_GC gc;
static struct uns_ctr empty_list;

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,
	LAMBDA,
	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 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();
	}

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

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

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_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);
			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_;
	printf("oom\n");
	abort();
}

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

static void display(struct uns_ctr *ctr, long indent)
{
	struct uns_ctr tmp = {0};
	long l;
	double f;

	if (!ctr->p) {
		printf("<undefined>");
		return;
	}

	switch (get_type(ctr->p)) {
	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 {
				printf(" ");
				display(&tmp, indent);
			}

			ctr->p = uns_get(gc, ctr->p, 2, NULL);
		}

		switch (get_type(ctr->p)) {
		case EMPTY_LIST:
			printf(")");
			break;
		default:
			printf(" . ");
			display(ctr, indent);
			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();
	}
}

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

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 file input = {0};
	input.loc.line = 1;

	init();
	uns_root_add(gc, &expr);
	input.f = stdin;

	while (!feof(input.f)) {
		expr.p = NULL;
		switch (expr_parse(&input, &expr)) {
		case EXPR_PARSE_OK:
			expr.p = uns_get(gc, expr.p, 0, NULL);
			display(&expr, 1);
			printf("\n");
			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");
			break;
		}
	}

	uns_root_remove(gc, &expr);
	uns_deinit(gc);
	return 0;
}