keithlisp/main.c

#include "main.h"

lisp_cons* syms_alist;
lisp_cons* funs_alist;
lisp_cons* atoms_alist;

bool lisp_is_nil(lisp_value value) {
	return (value.type == LISP_T_CONS) && (value.value.cons == NULL);
}
bool lisp_is_equal(lisp_value a, lisp_value b) {
	if (a.type != b.type)
		return false;
	switch (a.type) {
		case LISP_T_CONS:
			return a.value.cons == b.value.cons;
		case LISP_T_ATOM:
			return a.value.atom == b.value.atom;
		case LISP_T_INT:
			return a.value._int == b.value._int;
		case LISP_T_FLOAT:
			return a.value._float == b.value._float;
		case LISP_T_STRING:
			return lisp_string_cmp(a.value.string, b.value.string) == 0;
		default:
			return false;
	}
}

void lisp_cons_join(lisp_cons* head, lisp_cons* tail) {
	while ((head->cdr.type == LISP_T_CONS) && !lisp_is_nil(head->cdr)) {
		head = head->cdr.value.cons;
	}
	head->cdr.type = LISP_T_CONS;
	head->cdr.value.cons = tail;
}

lisp_atom atom_t;
lisp_atom atom_quote;

#include "crc_table.h"
lisp_atom lisp_atomize(lisp_string* atom_lstr) {
	char* buf = lisp_string_data(atom_lstr);
	int len = lisp_string_len(atom_lstr);
	lisp_atom atom = 0xFFFFFFFF;
	while (len--) {
		atom = (atom << 8) ^ crc32_table[((atom >> 24) ^ *buf) & 255];
		buf++;
	}
#ifdef LISP_USE_ATOMS_ALIST
	lisp_value key;
	key.type = LISP_T_ATOM;
	key.value.atom = atom;
	if (lisp_alist_getptr(atoms_alist, key) == NULL) {
		lisp_cons* pair = dbg_malloc(sizeof(lisp_cons));
		pair->car.type = LISP_T_ATOM;
		pair->car.value.atom = atom;
		pair->cdr.type = LISP_T_STRING;
		pair->cdr.value.string = lisp_string_copy(atom_lstr);
		lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
		new_alist->car.type = LISP_T_CONS;
		new_alist->car.value.cons = pair;
		new_alist->cdr.type = LISP_T_CONS;
		new_alist->cdr.value.cons = atoms_alist;
		atoms_alist = new_alist;
	}
#endif
	return atom;
}
lisp_atom lisp_atom_init(lisp_string* atom_lstr) {
	lisp_atom atom = lisp_atomize(atom_lstr);
	dbg_free(atom_lstr);
	return atom;
}

lisp_cons** lisp_alist_getptr(lisp_cons* alist, lisp_value key) {
	while (alist != NULL) {
		if (alist->car.type != LISP_T_CONS || alist->car.value.cons == NULL)
			goto next;
		lisp_cons* pair = alist->car.value.cons;
		if (lisp_is_equal(pair->car, key))
			return &alist->car.value.cons;
	next:
		if (alist->cdr.type == LISP_T_CONS)
			alist = alist->cdr.value.cons;
		else
			alist = NULL;
	}
	return NULL;
}
lisp_cons* lisp_alist_get(lisp_cons* alist, lisp_value key) {
	lisp_cons** pairptr = lisp_alist_getptr(alist, key);
	if (pairptr == NULL)
		return NULL;
	return *pairptr;
}
lisp_cons* lisp_alist_put(lisp_cons** alist, lisp_cons* pair) {
	lisp_cons** pairptr = lisp_alist_getptr(*alist, pair->car);
	if (pairptr != NULL) {
		lisp_cons* old_pair = *pairptr;
		*pairptr = pair;
		return old_pair;
	}
	lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
	new_alist->car.type = LISP_T_CONS;
	new_alist->car.value.cons = pair;
	new_alist->cdr.type = LISP_T_CONS;
	new_alist->cdr.value.cons = *alist;
	*alist = new_alist;
	return NULL;
}
lisp_cons* lisp_alist_del(lisp_cons** alist, lisp_value key) {
	lisp_cons* alist_cur = *alist;
	lisp_cons* alist_prev = NULL;
	while (alist_cur != NULL) {
		if (alist_cur->car.type != LISP_T_CONS || alist_cur->car.value.cons == NULL)
			goto next;
		lisp_cons* pair = alist_cur->car.value.cons;
		if (lisp_is_equal(pair->car, key)) {
			// remove current element from list
			if (alist_prev != NULL)
				alist_prev->cdr = alist_cur->cdr;
			else if (alist_cur->cdr.type == LISP_T_CONS)
				*alist = alist_cur->cdr.value.cons;
			dbg_free(alist_cur);
			return pair;
		}
	next:
		alist_prev = alist_cur;
		if (alist_cur->cdr.type == LISP_T_CONS)
			alist_cur = alist_cur->cdr.value.cons;
		else
			alist_cur = NULL;
	}
	return NULL;
}

void print_value(lisp_value value) {
	if (lisp_is_nil(value))
		printf("nil");
	else if (value.type == LISP_T_CONS)
		print_cons(value.value.cons);
	else if (value.type == LISP_T_ATOM) {
#ifdef LISP_USE_ATOMS_ALIST
		lisp_cons* pair = lisp_alist_get(atoms_alist, value);
		if (pair != NULL)
			lisp_string_print(pair->cdr.value.string);
		else
#endif
		printf("<atom %08x>", value.value.atom);
	} else if (value.type == LISP_T_INT)
		printf("%li", value.value._int);
	else if (value.type == LISP_T_FLOAT)
		printf("%g", value.value._float);
	else if (value.type == LISP_T_STRING) {
		putchar('\"');
		lisp_string_print(value.value.string);
		putchar('\"');
	} else if (value.type == LISP_T_FUNPTR)
		printf("<native-fun %p>", value.value.funptr);
}
void print_cons(lisp_cons* cons) {
	printf("(");
	while (cons != NULL) {
		print_value(cons->car);
		if (cons->cdr.type == LISP_T_CONS) {
			cons = cons->cdr.value.cons;
			if (cons != NULL)
				printf(" ");
		} else {
			printf(" . ");
			print_value(cons->cdr);
			cons = NULL;
		}
	}
	printf(")");
}

void recursive_free(lisp_cons* cons) {
	while (cons != NULL) {
		if (cons->car.type == LISP_T_STRING)
			dbg_free(cons->car.value.string);
		else if (cons->car.type == LISP_T_CONS)
			recursive_free(cons->car.value.cons);
		if (cons->cdr.type == LISP_T_STRING)
			dbg_free(cons->cdr.value.string);
		lisp_cons* next_cons = NULL;
		if (cons->cdr.type == LISP_T_CONS)
			next_cons = cons->cdr.value.cons;
		dbg_free(cons);
		cons = next_cons;
	}
}

bool fetch_tokens(lisp_cons** tokens) {
	char buf[64];
	//test_print_cons(*tokens);
	//printf("> ");
	if (!fgets(buf, 64, stdin))
		return false;
	lisp_tokenize(buf, strlen(buf), tokens);
	return true;
}

// funs-alist entry: (name . (flags . fun)) - unless flags is 0
lisp_cons* lisp_create_fundef(lisp_atom atom, long flags, lisp_value fun) {
	lisp_cons* cons = dbg_malloc(sizeof(lisp_cons));
	cons->car.type = LISP_T_ATOM;
	cons->car.value.atom = atom;
	if (flags) {
		cons->cdr.type = LISP_T_CONS;
		cons->cdr.value.cons = dbg_malloc(sizeof(lisp_cons));
		cons->cdr.value.cons->car.type = LISP_T_INT;
		cons->cdr.value.cons->car.value._int = flags;
		cons->cdr.value.cons->cdr = fun;
	} else {
		cons->cdr = fun;
	}
	lisp_alist_put(&funs_alist, cons);
	return cons;
}

lisp_atom lisp_defun_native(lisp_string* lstr, lisp_native_fun funptr) {
	lisp_atom atom = lisp_atom_init(lstr);
	lisp_create_fundef(atom, 0, (lisp_value){.type = LISP_T_FUNPTR, .value = {.funptr = funptr}});
	return atom;
}

lisp_cons* lisp_defun(lisp_atom atom, lisp_cons* fun) {
	return lisp_create_fundef(atom, 0, (lisp_value){.type = LISP_T_CONS, .value = {.cons = fun}});
}

lisp_atom lisp_defun_special_native(lisp_string* lstr, long flags, lisp_native_fun funptr) {
	lisp_atom atom = lisp_atom_init(lstr);
	lisp_create_fundef(atom, flags, (lisp_value){.type = LISP_T_FUNPTR, .value = {.funptr = funptr}});
	return atom;
}

lisp_cons* lisp_defun_special(lisp_atom atom, long flags, lisp_cons* fun) {
	return lisp_create_fundef(atom, flags, (lisp_value){.type = LISP_T_CONS, .value = {.cons = fun}});
}

void lisp_evaluate_value(lisp_value input, lisp_value* result) {
	if (input.type == LISP_T_ATOM) {
		if (input.value.atom == atom_t) {
			*result = input;
			return;
		}
		lisp_cons* sym_pair = lisp_alist_get(syms_alist, input);
		if (sym_pair != NULL)
			*result = sym_pair->cdr;
		else {
			result->type = LISP_T_CONS;
			result->value.cons = NULL;
		}
	} else if (input.type == LISP_T_CONS && !lisp_is_nil(input))
		lisp_evaluate(input.value.cons, result);
	else
		*result = input;
}
void lisp_evaluate(lisp_cons* cons, lisp_value* value) {
	value->type = LISP_T_CONS;
	value->value.cons = NULL;

	// can't use a switch here
	/*
	if (cons->car.value.atom == atom_quote) {
		*value = cons->cdr.value.cons->car;
		return;
	} else if (cons->car.value.atom == atom_cond) {
		lisp_sform_cond(cons->cdr.value.cons, value);
		return;
	} else if (cons->car.value.atom == atom_let) {
		lisp_sform_let(cons->cdr.value.cons, value);
		return;
	} else if (cons->car.value.atom == atom_defun) {
		lisp_sform_defun(cons->cdr.value.cons, value);
		return;
	}
	*/

	lisp_cons* fun_cons = lisp_alist_get(funs_alist, cons->car);
	if (fun_cons == NULL) {
		fprintf(stderr, "EVAL ERROR! (no such fun)\n");
		return;
	}
	long fun_flags = 0;
	lisp_value fun_val;
	if (fun_cons->cdr.type == LISP_T_CONS && fun_cons->cdr.value.cons != NULL
	    && fun_cons->cdr.value.cons->car.type == LISP_T_INT) {
		fun_flags = fun_cons->cdr.value.cons->car.value._int;
		fun_val = fun_cons->cdr.value.cons->cdr;
	} else {
		fun_val = fun_cons->cdr;
	}

	lisp_cons* args = NULL;
	lisp_cons* args_tail = NULL;
	if ((fun_flags & LISP_FFLAG_RAWARG) == 0) {
		cons = cons->cdr.value.cons;
		while (cons != NULL) {
			lisp_cons* arg_cons = dbg_malloc(sizeof(lisp_cons));
			arg_cons->cdr.type = LISP_T_CONS;
			arg_cons->cdr.value.cons = NULL;
			lisp_evaluate_value(cons->car, &arg_cons->car);
			cons = cons->cdr.value.cons;
			if (args == NULL)
				args = arg_cons;
			if (args_tail == NULL)
				args_tail = args;
			else {
				args_tail->cdr.value.cons = arg_cons;
				args_tail = arg_cons;
			}
		}
	} else {
		args = recursive_copy(cons->cdr.value.cons);
	}

	if (fun_val.type == LISP_T_FUNPTR) {
		// native-fun
		(*fun_val.value.funptr)(args, value);
	} else if (fun_val.type == LISP_T_CONS) {
		// defun
		lisp_evaluate_defun(fun_val.value.cons, args, value);
	} else {
		fprintf(stderr, "EVAL ERROR! (not native-fun or defun)\n");
		return;
	}

	// free args
	while (args != NULL) {
		args_tail = args->cdr.value.cons;
		dbg_free(args);
		args = args_tail;
	}

	if (fun_flags & LISP_FFLAG_EVALRES)
		lisp_evaluate_value(*value, value);
}
void lisp_sform_quote(lisp_cons* cons, lisp_value* value) {
	*value = cons->car;
}
lisp_atom atom_cond;
void lisp_sform_cond(lisp_cons* cons, lisp_value* value) {
	while (cons != NULL) {
		lisp_cons* fork = cons->car.value.cons;
		lisp_evaluate_value(fork->car, value);
		if (!lisp_is_nil(*value)) {
			fork = fork->cdr.value.cons;
			while (fork != NULL) {
				lisp_evaluate_value(fork->car, value);
				fork = fork->cdr.value.cons;
			}
			return;
		}
		cons = cons->cdr.value.cons;
	}
	value->type = LISP_T_CONS;
	value->value.cons = NULL;
}
lisp_atom atom_let;
void lisp_sform_let(lisp_cons* cons, lisp_value* value) {
	// allocate local vars
	lisp_cons* vars_head = cons->car.value.cons;
	while (vars_head != NULL) {
		// create cons pair for new var
		lisp_cons* pair = dbg_malloc(sizeof(lisp_cons));
		if (vars_head->car.type == LISP_T_CONS) {
			pair->car = vars_head->car.value.cons->car;
			lisp_evaluate_value(vars_head->car.value.cons->cdr.value.cons->car, &pair->cdr);
		} else {
			pair->car = vars_head->car;
			pair->cdr.type = LISP_T_CONS;
			pair->cdr.value.cons = NULL;
		}
		// add to alist
		lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
		new_alist->car.type = LISP_T_CONS;
		new_alist->car.value.cons = pair;
		new_alist->cdr.type = LISP_T_CONS;
		new_alist->cdr.value.cons = syms_alist;
		syms_alist = new_alist;

		vars_head = vars_head->cdr.value.cons;
	}
	// evaluate body
	lisp_cons* body_head = cons->cdr.value.cons;
	while (body_head != NULL) {
		lisp_evaluate_value(body_head->car, value);
		body_head = body_head->cdr.value.cons;
	}
	// delete local vars
	vars_head = cons->car.value.cons;
	while (vars_head != NULL) {
		lisp_value key;
		if (vars_head->car.type == LISP_T_CONS)
			key = vars_head->car.value.cons->car;
		else
			key = vars_head->car;
		lisp_cons* pair = lisp_alist_del(&syms_alist, key);
		dbg_free(pair);

		vars_head = vars_head->cdr.value.cons;
	}
}
lisp_atom atom_defun;
void lisp_sform_defun(lisp_cons* cons, lisp_value* value) {
	lisp_atom fun_name = cons->car.value.atom;
	lisp_cons* fun_data = recursive_copy(cons->cdr.value.cons);

	lisp_defun(fun_name, fun_data);
	value->type = LISP_T_CONS;
	value->value.cons = fun_data;
}
lisp_atom atom_defmacro;
void lisp_sform_defmacro(lisp_cons* cons, lisp_value* value) {
	lisp_atom fun_name = cons->car.value.atom;
	lisp_cons* fun_data = recursive_copy(cons->cdr.value.cons);

	lisp_defun_special(fun_name, LISP_FFLAG_EARLY|LISP_FFLAG_RAWARG|LISP_FFLAG_EVALRES, fun_data);
	value->type = LISP_T_CONS;
	value->value.cons = fun_data;
}

lisp_cons* recursive_copy(lisp_cons* cons) {
	lisp_cons* new_cons = dbg_malloc(sizeof(lisp_cons));
	lisp_cons* new_root = new_cons;
	while (cons != NULL) {
		new_cons->car = cons->car;
		new_cons->cdr = cons->cdr;

		if (cons->car.type == LISP_T_STRING)
			new_cons->car.value.string = lisp_string_copy(cons->car.value.string);
		else if (cons->car.type == LISP_T_CONS)
			new_cons->car.value.cons = recursive_copy(cons->car.value.cons);

		if (cons->cdr.type == LISP_T_STRING)
			new_cons->cdr.value.string = lisp_string_copy(cons->cdr.value.string);

		if (cons->cdr.type == LISP_T_CONS && cons->cdr.value.cons != NULL) {
			cons = cons->cdr.value.cons;
			new_cons->cdr.value.cons = dbg_malloc(sizeof(lisp_cons));
			new_cons = new_cons->cdr.value.cons;
		} else {
			cons = NULL;
		}
	}
	return new_root;
}

void lisp_evaluate_defun(lisp_cons* fun, lisp_cons* args, lisp_value* value) {
	// allocate local vars
	lisp_cons* head = fun->car.value.cons;
	while (head != NULL) {
		// create cons pair for new var
		lisp_cons* pair = dbg_malloc(sizeof(lisp_cons));
		pair->car.type = LISP_T_ATOM;
		pair->car.value.atom = head->car.value.atom;
		pair->cdr = args->car;
		args = args->cdr.value.cons;
		// add to alist
		lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
		new_alist->car.type = LISP_T_CONS;
		new_alist->car.value.cons = pair;
		new_alist->cdr.type = LISP_T_CONS;
		new_alist->cdr.value.cons = syms_alist;
		syms_alist = new_alist;

		head = head->cdr.value.cons;
	}

	// evaluate body
	head = fun->cdr.value.cons;
	while (head != NULL) {
		lisp_evaluate_value(head->car, value);
		head = head->cdr.value.cons;
	}

	// delete local vars
	head = fun->car.value.cons;
	while (head != NULL) {
		lisp_value key;
		if (head->car.type == LISP_T_CONS)
			key = head->car.value.cons->car;
		else
			key = head->car;
		lisp_cons* pair = lisp_alist_del(&syms_alist, key);
		dbg_free(pair);

		head = head->cdr.value.cons;
	}
}

lisp_atom atom_cons;
lisp_atom atom_atom;
lisp_atom atom_int;
lisp_atom atom_float;
lisp_atom atom_string;
lisp_atom atom_native_fun;

int main() {
	printf("sizeof(lisp_atom)   = %lu\n", sizeof(lisp_atom));
	printf("sizeof(lisp_value)  = %lu\n", sizeof(lisp_value));
	printf("sizeof(lisp_cons)   = %lu\n", sizeof(lisp_cons));

	atom_t = lisp_atom_init(lisp_string_create("t"));
	/*
	atom_quote = lisp_atom_init(lisp_string_create("quote"));

	atom_cond = lisp_atom_init(lisp_string_create("cond"));
	atom_let = lisp_atom_init(lisp_string_create("let"));
	atom_defun = lisp_atom_init(lisp_string_create("defun"));
	*/

	atom_quote = lisp_defun_special_native(lisp_string_create("quote"), LISP_FFLAG_RAWARG, &lisp_sform_quote);
	atom_cond = lisp_defun_special_native(lisp_string_create("cond"), LISP_FFLAG_RAWARG, &lisp_sform_cond);
	atom_let = lisp_defun_special_native(lisp_string_create("let"), LISP_FFLAG_RAWARG, &lisp_sform_let);
	atom_defun = lisp_defun_special_native(lisp_string_create("defun"), LISP_FFLAG_RAWARG, &lisp_sform_defun);
	atom_defmacro = lisp_defun_special_native(lisp_string_create("defmacro"), LISP_FFLAG_RAWARG, &lisp_sform_defmacro);

	atom_cons = lisp_atom_init(lisp_string_create("cons"));
	atom_atom = lisp_atom_init(lisp_string_create("atom"));
	atom_int = lisp_atom_init(lisp_string_create("int"));
	atom_float = lisp_atom_init(lisp_string_create("float"));
	atom_string = lisp_atom_init(lisp_string_create("string"));
	atom_native_fun = lisp_atom_init(lisp_string_create("native-fun"));

	init_native_funs();

	size_t init_mem_usage = dbg_malloc_mem_usage;
	printf("Init: %4liB used\n", init_mem_usage);

	while (true) {
		lisp_cons* tokens = NULL;
		lisp_value value;
		printf("%4liB> ", dbg_malloc_mem_usage-init_mem_usage);
		lisp_tokenize_init();
		if (lisp_parse_recursive(&tokens, &fetch_tokens, &value)) {
			//test_print_value(value);
			//printf("\n");
			lisp_value result;
			lisp_evaluate_value(value, &result);
			print_value(result);
			printf("\n");
			//printf("Freeing sexpr...\n");
			if (value.type == LISP_T_CONS)
				recursive_free(value.value.cons);
			else if (value.type == LISP_T_STRING)
				dbg_free(value.value.string);
			//printf("Freeing tokens...\n");
			recursive_free(tokens);

			if (lisp_is_nil(value))
				break;
		} else {
			printf("PARSE ERROR!\n");
			print_cons(tokens);
			printf("\n");
		}
	}

	//printf("Freeing syms-alist...\n");
	recursive_free(syms_alist);
	//printf("Freeing funs-alist...\n");
	recursive_free(funs_alist);
	//printf("Freeing atoms-alist...\n");
	recursive_free(atoms_alist);
	printf("Done: %4liB used (should be 0)\n", dbg_malloc_mem_usage);
	printf("Peak: %4liB used\n", dbg_malloc_peak_usage);

	return 0;
}