#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <assert.h>
#include <ctype.h>

#ifdef CONFIG_GC
#include <gc/gc.h>
#define malloc(n) GC_MALLOC(n)
#endif

#define TYPE_CONS 1
#define TYPE_INT  2
#define TYPE_STR  3
#define TYPE_NIL  4
#define TYPE_SYM  5
#define TYPE_PRIMITIVE 6
#define TYPE_FUN 7
#define TYPE_MACRO 8

struct value_t {
    int type;
    void *data;
};
typedef struct value_t *value;

struct cons_t {
    value car;
    value cdr;
};
typedef struct cons_t *cons;

struct frame_t {
    char *key;
    value value;
    struct frame_t *next;
};
typedef struct frame_t *frame;

struct environment_t {
    frame frame;
    struct environment_t *next;
};
typedef struct environment_t *environment;

struct fun_t {
    value args;
    value body;
    environment env;
};
typedef struct fun_t *fun;

typedef struct {
    int verbose;
} opt_t;

opt_t opt;

value eval(value v, environment e);
value cons_new(value car, value cdr);


value value_new(int type, void *data) {
    value v;
    v = malloc(sizeof(struct value_t));
    assert(v);
    v->type = type;
    v->data = data;
    return v;
}

value car(value v) {
    assert(v->type == TYPE_CONS);
    return ((cons)v->data)->car;
}
value cdr(value v) {
    assert(v->type == TYPE_CONS);
    return ((cons)v->data)->cdr;
}

int issymbol(char c, int notfirst) {
    char valid[] = "!$%&*+-./:<=>?@^_~";
    if (!notfirst && isdigit(c)) {
	return 0;
    }
    return isalnum(c) || strchr(valid, c) != NULL;
}

void skip_whitespace(char **str) {
    while (**str == '\n' || **str == ' ' || **str == ';' || **str == '\t') {
	if (**str == ';') {
	    char *p;
	    p = strchr(*str+1, '\n');
	    assert(p);
	    *str = p + 1;
	} else {
	    (*str)++;
	}
    }
}
value parse_str(char **str) {
    char *p, *q;
    value v;

    skip_whitespace(str);
    assert(**str != '\0');
    if (**str == '"') {
	p = strchr(*str+1, '"');
	assert(p);
	*p = '\0';
	q = strdup(*str+1);
	assert(q);
	*p = '"';
	v = value_new(TYPE_STR, q);
	*str = p + 1;
	return v;
    }
    if (isdigit(**str)) {
	char orig, *end;
	p = *str;
	while (isdigit(*p)) {
	    p++;
	}
	orig = *p;
	*p = '\0';
	v = value_new(TYPE_INT, (void*)strtol(*str, &end, 10));
	assert(*end == '\0');
	*p = orig;
	*str = p;
	return v;
    }
    if (issymbol(**str, 0)) {
	char orig;
	p = *str;
	while (issymbol(*p, 1)) {
	    p++;
	}

	orig = *p;
	*p = '\0';
	q = strdup(*str);
	assert(q);
	*p = orig;

	v = value_new(TYPE_SYM, q);
	*str = p;
	return v;
    }
    if (**str == '\'') {
	(*str)++;
	v = parse_str(str);
	return cons_new(value_new(TYPE_SYM, "quote"),
			cons_new(v, value_new(TYPE_NIL, NULL)));
    }
    if (**str == '(' && *(*str+1) == ')') {
	v = value_new(TYPE_NIL, NULL);
	*str += 2;
	return v;
    }
    if (**str == '(') {
	cons c, c2;
	value v2;
	
	c = malloc(sizeof(struct cons_t));
	assert(c);

	v = value_new(TYPE_CONS, c);

	assert(**str == '(');
	(*str)++;
	for (;;) {
	    c->car = parse_str(str);
	    skip_whitespace(str);
	    if (**str == ')') {
		char *tmp = "()";
		c->cdr = parse_str(&tmp);
		break;
	    }
	    c2 = malloc(sizeof(struct cons_t));
	    assert(c2);
	    v2 = value_new(TYPE_CONS, c2);
	    c->cdr = v2;
	    c = c2;
	}
	assert(**str == ')');
	(*str)++;
	return v;
    }
    printf("Parse error at: %s\n", *str);
    assert(0);
}

void print(value v) {
    int first_time = 1;
    switch (v->type) {
    case TYPE_INT:
	printf("%d", (int)v->data);
	break;
    case TYPE_STR:
	printf("\"%s\"", (char*)v->data);
	break;
    case TYPE_NIL:
	printf("()");
	break;
    case TYPE_SYM:
	printf("%s", (char*)v->data);
	break;
    case TYPE_PRIMITIVE:
	printf("#<primitive:%p>", v->data);
	break;
    case TYPE_FUN:
	printf("#<%p:", v->data);
	print(((fun)v->data)->args);
	printf(">");
	break;
    case TYPE_MACRO:
	printf("#<%p:macro:", v->data);
	print(((fun)v->data)->args);
	printf(">");
	break;
    case TYPE_CONS:
	printf("(");
	// (1 2 3 4 5)
	while (v->type == TYPE_CONS) {
	    if (!first_time) {
		printf(" ");
	    } else {
		first_time = 0;
	    }
	    print(car(v));
	    v = cdr(v);
	}
	
	if (v->type == TYPE_NIL) {
	    printf(")");
	    return;
	}
	printf(" . ");
	print(v);
	printf(")");
	return;
	
	break;
    default:
	printf("unknown value of type %d\n", v->type);
	assert(0);
    }
}

frame frame_add(frame f, char *key, value val) {
    frame f2;
    f2 = malloc(sizeof(struct frame_t));
    assert(f2);
    f2->key = key;
    f2->value = val;
    f2->next = f;
    return f2;
}
value frame_find(frame f, char *key) {
    while (f) {
	if (!strcmp(f->key, key)) {
	    return f->value;
	}
	f = f->next;
    }
    return NULL;
}

environment environment_add_new_frame(environment e) {
    environment e2;
    e2 = malloc(sizeof(struct environment_t));
    e2->frame = NULL;
    e2->next = e;
    return e2;
}

void environment_add(environment e, char *key, value val) {
    e->frame = frame_add(e->frame, key, val);
}

value environment_find(environment e, char *key) {
    while (e) {
	value v;
	v = frame_find(e->frame, key);
	if (v) {
	    return v;
	}
	e = e->next;
    }
    return NULL;
}


value fun_new(value args, value body, environment e) {
    fun f;
    f = malloc(sizeof(struct fun_t));
    assert(f);
    f->args = args;
    f->body = body;
    f->env = e;
    return value_new(TYPE_FUN, f);
}


value cons_new(value car, value cdr) {
    cons c;
    value v;
    c = malloc(sizeof(struct cons_t));
    c->car = car;
    c->cdr = cdr;
    v = value_new(TYPE_CONS, c);
    return v;
}

value eval_map(value v, environment e) {
    if (v->type == TYPE_NIL) {
	return value_new(TYPE_NIL, NULL);
    }
    return cons_new(eval(car(v), e),
		    eval_map(cdr(v), e));
}

typedef value (*primitive_fun)(value, environment);

value primitive_plus(value v, environment e) {
    int sum = 0;
    while (v->type == TYPE_CONS) {
	assert(car(v)->type == TYPE_INT);
	sum += (int)car(v)->data;
	v = cdr(v);
    }
    assert(v->type == TYPE_NIL);
    return value_new(TYPE_INT, (void*)sum);
}

value primitive_minus(value v, environment e) {
    assert(car(v)->type == TYPE_INT);
    assert(car(cdr(v))->type == TYPE_INT);
    return value_new(TYPE_INT,
		     (void*)((int)car(v)->data - (int)car(cdr(v))->data));
}

value primitive_mult(value v, environment e) {
    int sum = 1;
    while (v->type == TYPE_CONS) {
	assert(car(v)->type == TYPE_INT);
	sum *= (int)car(v)->data;
	v = cdr(v);
    }
    assert(v->type == TYPE_NIL);
    return value_new(TYPE_INT, (void*)sum);
}

value primitive_lt(value v, environment e) {
    assert(car(v)->type == TYPE_INT);
    assert(car(cdr(v))->type == TYPE_INT);
    return value_new((int)car(v)->data <
		     (int)car(cdr(v))->data ?
		     TYPE_INT : TYPE_NIL, NULL);
}

value primitive_inteq(value v, environment e) {
    assert(car(v)->type == TYPE_INT);
    assert(car(cdr(v))->type == TYPE_INT);
    return value_new((int)car(v)->data ==
		     (int)car(cdr(v))->data ?
		     TYPE_INT : TYPE_NIL, NULL);
}

value primitive_eq(value v, environment e) {
    assert(car(v)->type == TYPE_SYM);
    assert(car(cdr(v))->type == TYPE_SYM);
    return value_new(!strcmp(car(v)->data, car(cdr(v))->data) ?
		     TYPE_INT : TYPE_NIL, NULL);
}

value primitive_cons(value v, environment e) {
    assert(cdr(v)->type == TYPE_CONS);
    assert(cdr(cdr(v))->type == TYPE_NIL);
    return cons_new(car(v),
		    car(cdr(v)));
}
value primitive_car(value v, environment e) {
    assert(car(v)->type == TYPE_CONS);
    return car(car(v));
}

value primitive_cdr(value v, environment e) {
    assert(car(v)->type == TYPE_CONS);
    return cdr(car(v));
}

value primitive_list(value v, environment e) {
    return v;
}

value primitive_intp(value v, environment e) {
    return value_new(car(v)->type == TYPE_INT ?
		     TYPE_INT : TYPE_NIL,
		     NULL);
}
value primitive_symbolp(value v, environment e) {
    return value_new(car(v)->type == TYPE_SYM ?
		     TYPE_INT : TYPE_NIL,
		     NULL);
}
value primitive_consp(value v, environment e) {
    return value_new(car(v)->type == TYPE_CONS ?
		     TYPE_INT : TYPE_NIL,
		     NULL);
}

value primitive_print(value v, environment e) {
    print(car(v));
    return value_new(TYPE_NIL, NULL);
}

/* ugly hack, always allocates 16K */
char *file_read(char *file, int *len) {
    int ret;
    char *p;
    FILE *fp;
    p = malloc(1024*16);
    assert(p);
    fp = fopen(file, "r");
    assert(fp);
    ret = fread(p, 1, 1024*16, fp);
    assert(ret > 0);
    assert(ret < 1024*16);
    p[ret] = 0;
    *len = ret;
    fclose(fp);
    return p;
}

value primitive_load(value v, environment e) {
    char *str;
    int str_len;
    assert(car(v)->type == TYPE_STR);
    str = file_read((char*)car(v)->data, &str_len);
    for (;;) {
	skip_whitespace(&str);
	if (*str == '\0') {
	    break;
	}
	v = parse_str(&str);
	eval(v, e);
    }
    return value_new(TYPE_NIL, NULL);
}

value eval_str(char *str, environment e) {
    char *p = strdup(str);
    assert(p);
    return eval(parse_str(&p), e);
}

environment environment_init(void) {
    environment e;
    e = environment_add_new_frame(NULL);
    environment_add(e, "+", value_new(TYPE_PRIMITIVE, primitive_plus));
    environment_add(e, "-", value_new(TYPE_PRIMITIVE, primitive_minus));
    environment_add(e, "*", value_new(TYPE_PRIMITIVE, primitive_mult));
    environment_add(e, "<", value_new(TYPE_PRIMITIVE, primitive_lt));
    environment_add(e, "=", value_new(TYPE_PRIMITIVE, primitive_inteq));
    environment_add(e, "eq?", value_new(TYPE_PRIMITIVE, primitive_eq));
    environment_add(e, "cons", value_new(TYPE_PRIMITIVE, primitive_cons));
    environment_add(e, "car", value_new(TYPE_PRIMITIVE, primitive_car));
    environment_add(e, "cdr", value_new(TYPE_PRIMITIVE, primitive_cdr));
    environment_add(e, "list", value_new(TYPE_PRIMITIVE, primitive_list));
    environment_add(e, "int?", value_new(TYPE_PRIMITIVE, primitive_intp));
    environment_add(e, "number?", value_new(TYPE_PRIMITIVE, primitive_intp));
    environment_add(e, "symbol?", value_new(TYPE_PRIMITIVE, primitive_symbolp));
    environment_add(e, "pair?", value_new(TYPE_PRIMITIVE, primitive_consp));
    environment_add(e, "print", value_new(TYPE_PRIMITIVE, primitive_print));
    environment_add(e, "load", value_new(TYPE_PRIMITIVE, primitive_load));
    
    eval_str("(define not (lambda (expr) (if expr () 0)))", e);
    eval_str("(define map (lambda (fun list) (if (not list) () "
	     "(cons (fun (car list)) "
	     "(map fun (cdr list))))))", e);
    eval_str("(define cadr (lambda (l) (car (cdr l))))", e);
    eval_str("(define caddr (lambda (l) (car (cdr (cdr l)))))", e);
    eval_str("(define else 0)", e);
    eval_str("(defmacro let2 (lambda (v) "
	     "(cons (cons (quote lambda)"
	     "            (cons " "(map car (car v))"
	     "                  (cdr v)))"
	     "      " "(map cadr (car v))" ")"
	     "))", e);
    return e;
}

value evalimpl(value v, environment e) {
    value ret;
    switch(v->type) {
    case TYPE_INT:
    case TYPE_STR:
    case TYPE_NIL:
    case TYPE_PRIMITIVE:
    case TYPE_FUN:
	return v;
	break;
    case TYPE_SYM:
	ret = environment_find(e, (char*)v->data);
	assert(ret);
	return ret;
	break;
    case TYPE_CONS:
	// (+ 1 2 3)
	// (lambda (x a b) (+ a x b))
	// (define foo 2)
	// (define foo lambda (x a b) (+ a x b))
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "define")) {
	    if (car(cdr(v))->type == TYPE_SYM) {
		ret = eval(car(cdr(cdr(v))), e);
		environment_add(e,
				car(cdr(v))->data,
				ret);
		return car(cdr(v));
	    }
	    assert(car(cdr(v))->type == TYPE_CONS);
	    return eval(cons_new(value_new(TYPE_SYM, "define"),
				 cons_new(car(car(cdr(v))),
					  cons_new(cons_new(value_new(TYPE_SYM, "lambda"),
							    cons_new(cdr(car(cdr(v))),
								     cdr(cdr(v)))),
						   value_new(TYPE_NIL, NULL)))), e);
	}
	// (defmacro foo (lambda (x) (cons 1 x)))
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "defmacro")) {
	    assert(car(cdr(v))->type == TYPE_SYM);
	    ret = eval(car(cdr(cdr(v))), e);
	    assert(ret->type == TYPE_FUN);
	    ret->type = TYPE_MACRO;
	    environment_add(e,
			    car(cdr(v))->data,
			    ret);
	    return car(cdr(v));
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "lambda")) {
	    assert(car(cdr(v))->type == TYPE_CONS || car(cdr(v))->type == TYPE_NIL);
	    assert(cdr(cdr(v))->type == TYPE_CONS);
	    return fun_new(car(cdr(v)),
			   car(cdr(cdr(v))),
			   e);

	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "if")) {
	    value pred;
	    assert(cdr(v)->type == TYPE_CONS);
	    assert(cdr(cdr(v))->type == TYPE_CONS);

	    pred = eval(car(cdr(v)), e);
	    if (pred->type != TYPE_NIL) {
		return eval(car(cdr(cdr(v))), e);
	    }
	    if (cdr(cdr(cdr(v)))->type == TYPE_CONS) {
		return eval(car(cdr(cdr(cdr(v)))), e);
	    } else {
		return value_new(TYPE_NIL, NULL);
	    }
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "quote")) {
	    assert(cdr(v)->type == TYPE_CONS);
	    return car(cdr(v));
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "let")) {
	    value variables, values;
	    // (let ((a 1) (b 2)) x)
	    // ((lambda (a b) x) 1 2)
	    // (map car (quote ((a 1) (b 2))))
	    variables = eval(cons_new(value_new(TYPE_SYM, "map"),
				      cons_new(value_new(TYPE_SYM, "car"),
					       cons_new(cons_new(value_new(TYPE_SYM, "quote"),
								 cons_new(car(cdr(v)),
									  value_new(TYPE_NIL, NULL))),
							value_new(TYPE_NIL, NULL)))), e);
	    // (map cadr (quote ((a 1) (b 2))))
	    values = eval(cons_new(value_new(TYPE_SYM, "map"),
				   cons_new(value_new(TYPE_SYM, "cadr"),
					    cons_new(cons_new(value_new(TYPE_SYM, "quote"),
							      cons_new(car(cdr(v)),
								       value_new(TYPE_NIL, NULL))),
						     value_new(TYPE_NIL, NULL)))), e);
	    return eval(cons_new(cons_new(value_new(TYPE_SYM, "lambda"),
					  cons_new(variables,
						   cdr(cdr(v)))),
				 values), e);
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "and")) {
	    ret = value_new(TYPE_INT, NULL);
	    value v2 = cdr(v);
	    while (v2->type == TYPE_CONS) {
		ret = eval(car(v2), e);
		if (ret->type == TYPE_NIL) {
		    break;
		}
		v2 = cdr(v2);
	    }
	    return ret;
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "or")) {
	    ret = value_new(TYPE_NIL, NULL);
	    value v2 = cdr(v);
	    while (v2->type == TYPE_CONS) {
		ret = eval(car(v2), e);
		if (ret->type != TYPE_NIL) {
		    break;
		}
		v2 = cdr(v2);
	    }
	    return ret;
	}
	if (car(v)->type == TYPE_SYM &&
	    !strcmp((char*)car(v)->data, "cond")) {
	    if (cdr(v)->type == TYPE_NIL) {
		return cdr(v);
	    }
	    return eval(cons_new(value_new(TYPE_SYM, "if"),
				 cons_new(car(car(cdr(v))),
					  cons_new(car(cdr(car(cdr(v)))),
						   cons_new(cons_new(value_new(TYPE_SYM, "cond"),
								     cdr(cdr(v))), value_new(TYPE_NIL, NULL))))), e);
	}
	if (car(v)->type == TYPE_SYM &&
	    (ret = environment_find(e, (char*)car(v)->data)) && ret->type == TYPE_MACRO) {
	    value ev;
	    environment e2;
	    fun f;

	    ev = eval(car(v), e);
	    assert(ev->type == TYPE_MACRO);
	    f = (fun)ev->data;
	    e2 = environment_add_new_frame(f->env);
	    environment_add(e2,
			    (char*)car(f->args)->data,
			    cdr(v));
	    return eval(eval(f->body, e2), e);
	}
	{
	    value ev, arguments, parameters;
	    environment e2;
	    fun f;
	    
	    ev = eval_map(v, e);
	    if (car(ev)->type == TYPE_PRIMITIVE) {
		return ((primitive_fun)car(ev)->data)(cdr(ev), e);
	    }
	    assert(car(ev)->type == TYPE_FUN);
	    
	    f = (fun)car(ev)->data;
	    e2 = environment_add_new_frame(f->env);
	    parameters = f->args;
	    arguments = cdr(ev);
	    while (parameters->type == TYPE_CONS && arguments->type == TYPE_CONS) {
		assert(car(parameters)->type == TYPE_SYM);
		environment_add(e2,
				(char*)car(parameters)->data,
				car(arguments));
		arguments = cdr(arguments);
		parameters = cdr(parameters);
	    }
	    assert(parameters->type == TYPE_NIL && arguments->type == TYPE_NIL);
	    return eval(f->body, e2);
	}
	break;
    default:
	printf("unknown value of type %d\n", v->type);
	assert(0);
    }
}

value eval(value v, environment e) {
    static int depth = 0;
    int i;
    value ret;

    if (opt.verbose) {
	for (i = 0; i < depth; i++) {
	    putchar(i % 2 ? ' ' : '|');
	}
	print(v);
	putchar('\n');
    }
    depth++;
    ret = evalimpl(v, e);
    depth--;
    if (opt.verbose) {
	for (i = 0; i < depth; i++) {
	    putchar(i % 2 ? ' ' : '|');
	}
	print(ret);
	printf("\n");
    }
    return ret;
}

int main(int argc, char *argv[]) {
    value v;
    environment e;
    char buf[512];

    e = environment_init();
    while (fgets(buf, 512, stdin) != NULL) {
	char *p = buf;
	v = parse_str(&p);
	print(eval(v, e));
	printf("\n");
    }
    return 0;
}

// bugs
// (define a 2) (+ 2a) prints 4