keithlisp/native_funs.c

#include "native_funs.h"

void lisp_add(lisp_cons* cons, lisp_value* value) {
	long _int = 0;
	float _float = 0.0f;
	bool is_float = false;
	while (cons != NULL) {
		if (!is_float) {
			if (cons->car.type == LISP_T_INT)
				_int += cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT) {
				_float = (float) _int;
				is_float = true;
				_float += cons->car.value._float;
			}
		} else {
			if (cons->car.type == LISP_T_INT)
				_float += cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT)
				_float += cons->car.value._float;
		}
		cons = cons->cdr.value.cons;
	}
	if (is_float) {
		value->type = LISP_T_FLOAT;
		value->value._float = _float;
	} else {
		value->type = LISP_T_INT;
		value->value._int = _int;
	}
}
void lisp_sub(lisp_cons* cons, lisp_value* value) {
	long _int = 0;
	float _float = 0.0f;
	bool is_float = false;

	if (cons->car.type == LISP_T_FLOAT) {
		_float = cons->car.value._float;
		is_float = true;
	} else if (cons->car.type == LISP_T_INT) {
		_int = cons->car.value._int;
	} else {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}

	if (cons->cdr.value.cons == NULL) {
		if (is_float) {
			value->type = LISP_T_FLOAT;
			value->value._float = -_float;
		} else {
			value->type = LISP_T_INT;
			value->value._int = -_int;
		}
		return;
	} else
		cons = cons->cdr.value.cons;

	while (cons != NULL) {
		if (!is_float) {
			if (cons->car.type == LISP_T_INT)
				_int -= cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT) {
				_float = (float) _int;
				is_float = true;
				_float -= cons->car.value._float;
			}
		} else {
			if (cons->car.type == LISP_T_INT)
				_float -= cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT)
				_float -= cons->car.value._float;
		}
		cons = cons->cdr.value.cons;
	}
	if (is_float) {
		value->type = LISP_T_FLOAT;
		value->value._float = _float;
	} else {
		value->type = LISP_T_INT;
		value->value._int = _int;
	}
}
void lisp_mul(lisp_cons* cons, lisp_value* value) {
	long _int = 1;
	float _float = 1;
	bool is_float = false;
	while (cons != NULL) {
		if (!is_float) {
			if (cons->car.type == LISP_T_INT)
				_int *= cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT) {
				_float = (float) _int;
				is_float = true;
				_float *= cons->car.value._float;
			}
		} else {
			if (cons->car.type == LISP_T_INT)
				_float *= cons->car.value._int;
			else if (cons->car.type == LISP_T_FLOAT)
				_float *= cons->car.value._float;
		}
		cons = cons->cdr.value.cons;
	}
	if (is_float) {
		value->type = LISP_T_FLOAT;
		value->value._float = _float;
	} else {
		value->type = LISP_T_INT;
		value->value._int = _int;
	}
}
void lisp_div(lisp_cons* cons, lisp_value* value) {
	float _float = 0;

	if (cons->car.type == LISP_T_FLOAT)
		_float = cons->car.value._float;
	else if (cons->car.type == LISP_T_INT)
		_float = cons->car.value._int;
	else {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}

	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		if (cons->car.type == LISP_T_INT)
			_float /= cons->car.value._int;
		else if (cons->car.type == LISP_T_FLOAT)
			_float /= cons->car.value._float;
		cons = cons->cdr.value.cons;
	}
	value->type = LISP_T_FLOAT;
	value->value._float = _float;
}
void lisp_intdiv(lisp_cons* cons, lisp_value* value) {
	long _int = 0;

	if (cons->car.type == LISP_T_FLOAT)
		_int = cons->car.value._float;
	else if (cons->car.type == LISP_T_INT)
		_int = cons->car.value._int;
	else {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}

	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		if (cons->car.type == LISP_T_INT)
			_int /= cons->car.value._int;
		else if (cons->car.type == LISP_T_FLOAT)
			_int /= cons->car.value._float;
		cons = cons->cdr.value.cons;
	}
	value->type = LISP_T_INT;
	value->value._int = _int;
}

void lisp_not(lisp_cons* cons, lisp_value* value) {
	if (lisp_is_nil(cons->car)) {
		value->type = LISP_T_ATOM;
		value->value.atom = atom_t;
	} else {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
	}
}
void lisp_or(lisp_cons* cons, lisp_value* value) {
	while (cons != NULL) {
		if (!lisp_is_nil(cons->car)) {
			*value = cons->car;
			return;
		}
		cons = cons->cdr.value.cons;
	}
	value->type = LISP_T_CONS;
	value->value.cons = NULL;
}
void lisp_and(lisp_cons* cons, lisp_value* value) {
	value->type = LISP_T_CONS;
	value->value.cons = NULL;
	while (cons != NULL) {
		*value = cons->car;
		if (lisp_is_nil(cons->car))
			return;
		cons = cons->cdr.value.cons;
	}
}

void lisp_eq(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		if (!lisp_is_equal(cmp_value, cons->car)) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}
void lisp_num_eq(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	if (cmp_value.type != LISP_T_INT && cmp_value.type != LISP_T_FLOAT) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		bool cmp = false;
		if (cons->car.type == LISP_T_INT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int == cons->car.value._int);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float == cons->car.value._int);
		} else if (cons->car.type == LISP_T_FLOAT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int == cons->car.value._float);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float == cons->car.value._float);
		}
		if (!cmp) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}
void lisp_num_lt(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	if (cmp_value.type != LISP_T_INT && cmp_value.type != LISP_T_FLOAT) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		bool cmp = false;
		if (cons->car.type == LISP_T_INT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int < cons->car.value._int);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float < cons->car.value._int);
		} else if (cons->car.type == LISP_T_FLOAT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int < cons->car.value._float);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float < cons->car.value._float);
		}
		if (!cmp) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cmp_value = cons->car;
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}
void lisp_num_gt(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	if (cmp_value.type != LISP_T_INT && cmp_value.type != LISP_T_FLOAT) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		bool cmp = false;
		if (cons->car.type == LISP_T_INT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int > cons->car.value._int);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float > cons->car.value._int);
		} else if (cons->car.type == LISP_T_FLOAT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int > cons->car.value._float);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float > cons->car.value._float);
		}
		if (!cmp) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cmp_value = cons->car;
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}
void lisp_num_le(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	if (cmp_value.type != LISP_T_INT && cmp_value.type != LISP_T_FLOAT) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		bool cmp = false;
		if (cons->car.type == LISP_T_INT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int <= cons->car.value._int);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float <= cons->car.value._int);
		} else if (cons->car.type == LISP_T_FLOAT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int <= cons->car.value._float);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float <= cons->car.value._float);
		}
		if (!cmp) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cmp_value = cons->car;
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}
void lisp_num_ge(lisp_cons* cons, lisp_value* value) {
	lisp_value cmp_value = cons->car;
	if (cmp_value.type != LISP_T_INT && cmp_value.type != LISP_T_FLOAT) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	cons = cons->cdr.value.cons;
	while (cons != NULL) {
		bool cmp = false;
		if (cons->car.type == LISP_T_INT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int >= cons->car.value._int);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float >= cons->car.value._int);
		} else if (cons->car.type == LISP_T_FLOAT) {
			if (cmp_value.type == LISP_T_INT)
				cmp = (cmp_value.value._int >= cons->car.value._float);
			else if (cmp_value.type == LISP_T_FLOAT)
				cmp = (cmp_value.value._float >= cons->car.value._float);
		}
		if (!cmp) {
			value->type = LISP_T_CONS;
			value->value.cons = NULL;
			return;
		}
		cmp_value = cons->car;
		cons = cons->cdr.value.cons;
	}
	*value = cmp_value;
}

void lisp_type_of(lisp_cons* cons, lisp_value* value) {
	if (lisp_is_nil(cons->car)) {
		value->type = LISP_T_CONS;
		value->value.cons = NULL;
		return;
	}
	value->type = LISP_T_ATOM;
	switch (cons->car.type) {
		case LISP_T_CONS:
			value->value.atom = atom_cons;
			break;
		case LISP_T_ATOM:
			value->value.atom = atom_atom;
			break;
		case LISP_T_INT:
			value->value.atom = atom_int;
			break;
		case LISP_T_FLOAT:
			value->value.atom = atom_float;
			break;
		case LISP_T_STRING:
			value->value.atom = atom_string;
			break;
		case LISP_T_FUNPTR:
			value->value.atom = atom_native_fun;
			break;
	}
}

void lisp_addr_of(lisp_cons* cons, lisp_value* value) {
	value->type = LISP_T_INT;
	value->value._int = (long) cons->car.value.cons;
}

void init_native_funs() {
	// arithmetic
	lisp_defun_native(lisp_string_create("+"), &lisp_add);
	lisp_defun_native(lisp_string_create("-"), &lisp_sub);
	lisp_defun_native(lisp_string_create("*"), &lisp_mul);
	lisp_defun_native(lisp_string_create("/"), &lisp_div);
	lisp_defun_native(lisp_string_create("int/"), &lisp_intdiv);

	// boolean logic
	lisp_defun_native(lisp_string_create("not"), &lisp_not);
	lisp_defun_native(lisp_string_create("or"), &lisp_or);
	lisp_defun_native(lisp_string_create("and"), &lisp_and);

	// comparison
	lisp_defun_native(lisp_string_create("eq"), &lisp_eq);
	lisp_defun_native(lisp_string_create("="), &lisp_num_eq);
	lisp_defun_native(lisp_string_create("<"), &lisp_num_lt);
	lisp_defun_native(lisp_string_create(">"), &lisp_num_gt);
	lisp_defun_native(lisp_string_create("<="), &lisp_num_le);
	lisp_defun_native(lisp_string_create(">="), &lisp_num_ge);

	// etc
	lisp_defun_native(lisp_string_create("type-of"), &lisp_type_of);
	lisp_defun_native(lisp_string_create("addr-of"), &lisp_addr_of);
}