path: root/ss/builtin.cpp

#include "ms.h"
#include <list>
#include <map>
#include <algorithm>

namespace ms {

static inline bool number_p(Value *v) {
	return v->type == Value::INTEGER;
}

static inline intptr_t number_to_int(Value *v) {
	assert(number_p(v));
	return reinterpret_cast<intptr_t>(v->p1);
}

static Value *builtin_number_p(int argc, Value **argv) {
	return unshield().new_bool(number_p(argv[0]));
}

#define DEFINE_ARITH(name, op) \
	static Value *builtin_##name(int argc, Value **argv) { \
		if (!number_p(argv[0]) || !number_p(argv[1])) \
			return unshield().new_error(#op ": wrong argument type"); \
		return unshield().new_number(number_to_int(argv[0]) op number_to_int(argv[1])); \
	}
#define DEFINE_COMPARE(name, op) \
	static Value *builtin_##name(int argc, Value **argv) { \
		if (!number_p(argv[0]) || !number_p(argv[1])) \
			return unshield().new_error(#op ": wrong argument type"); \
		return unshield().new_bool(number_to_int(argv[0]) op number_to_int(argv[1])); \
	}
DEFINE_ARITH(add, +)
DEFINE_ARITH(sub, -)
DEFINE_ARITH(mul, *)
DEFINE_ARITH(div, /)
DEFINE_COMPARE(eq, ==)
DEFINE_COMPARE(lt, <)
DEFINE_COMPARE(leq, <=)
DEFINE_COMPARE(gt, >)
DEFINE_COMPARE(geq, >=)

// Lists
static inline bool null_p(Value *v) {
	return v->type == Value::NIL;
}

static inline bool pair_p(Value *v) {
	return v->type == Value::PAIR;
}

static Value *builtin_null_p(int argc, Value **argv) {
	return unshield().new_bool(null_p(argv[0]));
}

static Value *builtin_pair_p(int argc, Value **argv) {
	return unshield().new_bool(pair_p(argv[0]));
}

static Value *builtin_list_p(int argc, Value **argv) {
	Value *v = argv[0];
	while (true) {
		if (v->type == Value::NIL)
			return unshield().new_bool(true);
		if (v->type != Value::PAIR)
			return unshield().new_bool(false);
		v = (Value *)v->p2;
	}
}

static inline bool symbol_p(const Value *v) {
	return v->type == Value::SYMBOL;
}

static Value *builtin_symbol_p(int argc, Value **argv) {
	return unshield().new_bool(argv[0]->type == Value::SYMBOL);
}

static Value *builtin_car(int argc, Value **argv) {
	if (!pair_p(argv[0]))
		return unshield().new_error("car: pair expected");
	return (Value *)argv[0]->p1;
}

static Value *builtin_cdr(int argc, Value **argv) {
	if (!pair_p(argv[0]))
		return unshield().new_error("cdr: pair expected");
	return (Value *)argv[0]->p2;
}

static Value *builtin_cons(int argc, Value **argv) {
	return unshield().new_pair(argv[0], argv[1]);
}

static Value *builtin_list(int argc, Value **argv) {
	return unshield().new_list(argc, argv);
}

static Value *builtin_length(int argc, Value **argv) {
	size_t size = 0;
	Value *v = argv[0];
	while (true) {
		if (v->type == Value::NIL)
			return unshield().new_number(size);
		if (v->type != Value::PAIR)
			return unshield().new_number(size + 1); // FIXME: error?
		size++;
		v = (Value *)v->p2;
	}
}

static Value *builtin_eq_p(int argc, Value **argv);

static Value *builtin_memq(int argc, Value **argv) {
	Value *v = argv[1];
	while (true) {
		if (v->type == Value::NIL)
			return v;
		if (v->type != Value::PAIR)
			return unshield().new_nil(); // FIXME: error?

		Value *eq_args[2];
		eq_args[0] = argv[0];
		eq_args[1] = (Value *)v->p1;
		if (builtin_eq_p(2, eq_args)->test())
			return v;
		v = (Value *)v->p2;
	}
}

static Value *builtin_last(int argc, Value **argv) {
	Value *v = argv[1];
	if (!pair_p(argv[0]))
		return unshield().new_error("last: pair expected");
	while (true) {
		if (((Value *)v->p2)->type != Value::PAIR)
			return (Value *)v->p1;
		v = (Value *)v->p2;
	}
}

static Value *builtin_append(int argc, Value **argv) {
	assert(0);
}

static Value *builtin_set_car(int argc, Value **argv) {
	if (!pair_p(argv[0]))
		return unshield().new_error("set-car!: pair expected");
	// check, constantnedd
	argv[0]->p1 = argv[1];
	return unshield().new_nil();
}

static Value *builtin_set_cdr(int argc, Value **argv) {
	if (!pair_p(argv[0]))
		return unshield().new_error("set-cdr!: pair expected");
	// check, constantnedd
	argv[0]->p2 = argv[1];
	return unshield().new_nil();
}

// Boolean
static Value *builtin_boolean_p(int argc, Value **argv) {
	return unshield().new_bool(argv[0]->type == Value::BOOLEAN);
}

// String
static inline bool string_p(const Value *v) {
	return v->type == Value::STRING;
}

static Value *builtin_string_p(int argc, Value **argv) {
	return unshield().new_bool(argv[0]->type == Value::STRING);
}

static Value *builtin_string_append(int argc, Value **argv) {
	std::string *ret = new std::string();
	for (int i = 0; i < argc; i++) {
		const Value *s = argv[i];
		if (!string_p(s)) {
			delete ret;
			return unshield().new_error("string-append: string expected");
		}
		ret->append(*static_cast<const std::string *>(s->p1));
	}
	return unshield().new_string(ret);
}

static Value *builtin_symbol_to_string(int argc, Value **argv) {
	const Value *sym = argv[0];
	if (!symbol_p(sym))
		return unshield().new_error("symbol->string: symbol expected");
	return unshield().new_string(*static_cast<const std::string *>(sym->p1));
}

static Value *builtin_string_to_symbol(int argc, Value **argv) {
	const Value *str = argv[0];
	if (!string_p(str))
		return unshield().new_error("string->symbol: string expected");
	return unshield().new_symbol(*static_cast<const std::string *>(str->p1));
}

static Value *builtin_string_to_number(int argc, Value **argv) {
	const Value *str = argv[0];
	const std::string &s = *static_cast<const std::string *>(str->p1);
	intptr_t i = 0;
	for (std::string::const_iterator it = s.begin(); it != s.end(); ++it) {
		if (*it >= '0' && *it <= '9')
			i = i * 10 + (*it - '0');
		else
			return unshield().new_error("string->number: invalid character");
	}
	return unshield().new_number(i);
}

static Value *builtin_number_to_string(int argc, Value **argv) {
	const Value *num = argv[0];
	intptr_t i = reinterpret_cast<intptr_t>(num->p1);
	if (i == 0)
		return unshield().new_string("0");
	std::string *ret = new std::string();
	while (i) {
		intptr_t p = i / 10, q = i % 10;
		ret->push_back('0' + (char)q);
		i = p;
	}
	std::reverse(ret->begin(), ret->end());
	return unshield().new_string(ret);
}


// Function
static Value *builtin_procedure_p(int argc, Value **argv) {
	return unshield().new_bool(argv[0]->type == Value::LAMBDA ||
			argv[0]->type == Value::CFUNC ||
			argv[0]->type == Value::CALLCC ||
			argv[0]->type == Value::CONT);
}


// Comparison
static Value *builtin_eq_p(int argc, Value **argv) {
	if (argv[0] == argv[1])
		return unshield().new_bool(true);
	if (argv[0]->type != argv[1]->type)
		return unshield().new_bool(false);

	switch (argv[0]->type) {
	case Value::BOOLEAN:
		return unshield().new_bool(argv[0]->p1 == argv[1]->p1);
	case Value::SYMBOL: {
		const std::string &s0 = *static_cast<const std::string *>(argv[0]->p1),
		      &s1 = *static_cast<const std::string *>(argv[1]->p1);
		return unshield().new_bool(s0 == s1);
	}
	case Value::NIL:
		return unshield().new_bool(true);
	default:
		return unshield().new_bool(false);
	}
}

static Value *builtin_equal_p(int argc, Value **argv) {
	switch (argv[0]->type) {
	case Value::BOOLEAN:
	case Value::SYMBOL:
	case Value::NIL:
		return builtin_eq_p(argc, argv);
	default:
		// FIXME
		return unshield().new_bool(argv[0]->type == argv[1]->type &&
				argv[0]->p1 == argv[1]->p1 &&
				argv[0]->p2 == argv[1]->p2);
	}
}


// Debugging
static Value *builtin_dump(int argc, Value **argv) {
	dump(argv[0]);
	return argv[0];
}

static Value *builtin_dump_s(int argc, Value **argv) {
	return unshield().new_string(dump_s(argv[0]));
}



Value *get_cfunc(const std::string &id) {
	static std::map<const std::string, Value *> variables;
	static Memory::Shield shield(get_memory()); // FIXME
	if (variables.empty()) {
#define ADD(name, fname, argc) variables[name] = shield.new_cfunc(fname, argc)
		ADD("number?", builtin_number_p, 1);
		ADD("+", builtin_add, 2);
		ADD("-", builtin_sub, 2);
		ADD("*", builtin_mul, 2);
		ADD("/", builtin_div, 2);
		ADD("=", builtin_eq, 2);
		ADD("<", builtin_lt, 2);
		ADD("<=", builtin_leq, 2);
		ADD(">", builtin_gt, 2);
		ADD(">=", builtin_geq, 2);

		ADD("null?", builtin_null_p, 1);
		ADD("pair?", builtin_pair_p, 1);
		ADD("list?", builtin_list_p, 1);
		ADD("symbol?", builtin_symbol_p, 1);
		ADD("car", builtin_car, 1);
		ADD("cdr", builtin_cdr, 1);
		ADD("cons", builtin_cons, 2);
		ADD("list", builtin_list, -1);
		ADD("length", builtin_length, 1);
		ADD("memq", builtin_memq, 2);
		ADD("last", builtin_last, 1);
		ADD("append", builtin_append, -1);
		ADD("set-car!", builtin_set_car, 2);
		ADD("set-cdr!", builtin_set_cdr, 2);

		ADD("boolean?", builtin_boolean_p, 1);
		// not

		ADD("string?", builtin_string_p, 1);
		ADD("string-append", builtin_string_append, -1);
		ADD("symbol->string", builtin_symbol_to_string, 1);
		ADD("string->symbol", builtin_string_to_symbol, 1);
		ADD("string->number", builtin_string_to_number, 1);
		ADD("number->string", builtin_number_to_string, 1);

		ADD("procedure?", builtin_procedure_p, 1);

		ADD("eq?", builtin_eq_p, 2);
		// neq
		ADD("equal?", builtin_equal_p, 2);

		ADD("dump-s", builtin_dump_s, 1);
		ADD("display", builtin_dump, 1);
#undef ADD

#ifdef __MBED_CONFIG_DATA__
		extern void builtin_add_mbed(std::map<const std::string, Value *> &);
		builtin_add_mbed(variables);
#endif
	}
	return variables.at(id);
}

}