shithub: femtolisp

ref: 0f307a06c78f180cec17dc462d18207dbcd7edec
dir: /builtins.c/

/*
  Extra femtoLisp builtin functions
*/

#include "flisp.h"
#include "operators.h"
#include "cvalues.h"
#include "timefuncs.h"
#include "table.h"
#include "random.h"

#define DBL_MAXINT (1LL<<53)
#define FLT_MAXINT (1<<24)

size_t
llength(value_t v)
{
	size_t n = 0;
	while(iscons(v)){
		n++;
		v = cdr_(v);
	}
	return n;
}

BUILTIN("nconc", nconc)
{
	if(nargs == 0)
		return FL_nil;

	value_t lst, first = FL_nil;
	value_t *pcdr = &first;
	cons_t *c;
	uint32_t i = 0;

	while(1){
		lst = args[i++];
		if(i >= nargs)
			break;
		if(iscons(lst)){
			*pcdr = lst;
			c = ptr(lst);
			while(iscons(c->cdr))
				c = ptr(c->cdr);
			pcdr = &c->cdr;
		}else if(lst != FL_nil)
			type_error("cons", lst);
	}
	*pcdr = lst;
	return first;
}

BUILTIN("assq", assq)
{
	argcount(nargs, 2);

	value_t item = args[0];
	value_t v = args[1];
	value_t bind;

	while(iscons(v)){
		bind = car_(v);
		if(iscons(bind) && car_(bind) == item)
			return bind;
		v = cdr_(v);
	}
	return FL_f;
}

BUILTIN("memq", memq)
{
	argcount(nargs, 2);

	value_t v;
	cons_t *c;
	for(v = args[1]; iscons(v); v = c->cdr){
		if((c = ptr(v))->car == args[0])
			return v;
	}
	return FL_f;
}

BUILTIN("length", length)
{
	argcount(nargs, 1);

	value_t a = args[0];
	cvalue_t *cv;

	if(iscons(a)){
		size_t n = 0;
		value_t v = a, v2 = a;
		do{
			n++;
			v = cdr_(v);
			v2 = cdr_(v2);
			if(iscons(v2))
				v2 = cdr_(v2);
		}while(iscons(v) && iscons(v2) && v != v2);
		if(iscons(v2))
			return mk_double(D_PINF);
		n += llength(v);
		return size_wrap(n);
	}
	if(iscprim(a)){
		cv = ptr(a);
		if(cp_class(cv) == FL(bytetype))
			return fixnum(1);
		if(cp_class(cv) == FL(runetype))
			return fixnum(runelen(*(Rune*)cp_data(cv)));
	}
	if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
		return size_wrap(cvalue_arraylen(a));
	if(isvector(a))
		return size_wrap(vector_size(a));
	if(ishashtable(a)){
		htable_t *h = totable(a);
		void **t = h->table;
		size_t sz = h->size;
		size_t n = 0;
		for(size_t i = 0; i < sz; i += 2){
			if(t[i+1] != HT_NOTFOUND)
				n++;
		}
		return size_wrap(n);
	}
	if(a == FL_nil)
		return fixnum(0);
	type_error("sequence", a);
}

BUILTIN("raise", raise)
{
	argcount(nargs, 1);
	fl_raise(args[0]);
}

BUILTIN("exit", exit)
{
	if(nargs > 1)
		argcount(nargs, 1);
	fl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
}

BUILTIN("symbol", symbol)
{
	argcount(nargs, 1);
	if(__unlikely(!fl_isstring(args[0])))
		type_error("string", args[0]);
	return symbol(cvalue_data(args[0]), true);
}

BUILTIN("keyword?", keywordp)
{
	argcount(nargs, 1);
	return (issymbol(args[0]) &&
			iskeyword((symbol_t*)ptr(args[0]))) ? FL_t : FL_f;
}

BUILTIN("top-level-value", top_level_value)
{
	argcount(nargs, 1);
	symbol_t *sym = tosymbol(args[0]);
	if(sym->binding == UNBOUND)
		unbound_error(args[0]);
	return sym->binding;
}

BUILTIN("set-top-level-value!", set_top_level_value)
{
	argcount(nargs, 2);
	symbol_t *sym = tosymbol(args[0]);
	if(!isconstant(sym))
		sym->binding = args[1];
	return args[1];
}

BUILTIN("makunbound", makunbound)
{
	argcount(nargs, 1);
	symbol_t *sym = tosymbol(args[0]);
	if(!isconstant(sym))
		sym->binding = UNBOUND;
	return FL_t;
}

static void
global_env_list(symbol_t *root, value_t *pv)
{
	while(root != nil){
		if(root->name[0] != ':' && (root->binding != UNBOUND))
			*pv = fl_cons(tagptr(root, TAG_SYM), *pv);
		global_env_list(root->left, pv);
		root = root->right;
	}
}

BUILTIN("environment", environment)
{
	USED(args);
	argcount(nargs, 0);
	value_t lst = FL_nil;
	fl_gc_handle(&lst);
	global_env_list(FL(symtab), &lst);
	fl_free_gc_handles(1);
	return lst;
}

BUILTIN("constant?", constantp)
{
	argcount(nargs, 1);
	if(issymbol(args[0]))
		return isconstant((symbol_t*)ptr(args[0])) ? FL_t : FL_f;
	if(iscons(args[0])){
		if(car_(args[0]) == FL(quote))
			return FL_t;
		return FL_f;
	}
	return FL_t;
}

BUILTIN("integer-valued?", integer_valuedp)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(isfixnum(v))
		return FL_t;
	if(iscprim(v)){
		numerictype_t nt = cp_numtype(ptr(v));
		if(nt < T_FLOAT)
			return FL_t;
		void *data = cp_data(ptr(v));
		if(nt == T_FLOAT){
			float f = *(float*)data;
			if(f < 0)
				f = -f;
			if(f <= FLT_MAXINT && (float)(int32_t)f == f)
				return FL_t;
		}else{
			assert(nt == T_DOUBLE);
			double d = *(double*)data;
			if(d < 0)
				d = -d;
			if(d <= DBL_MAXINT && (double)(int64_t)d == d)
				return FL_t;
		}
	}
	return FL_f;
}

BUILTIN("integer?", integerp)
{
	argcount(nargs, 1);
	value_t v = args[0];
	return (isfixnum(v) ||
			(iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
		FL_t : FL_f;
}

BUILTIN("bignum?", bignump)
{
	argcount(nargs, 1);
	value_t v = args[0];
	return (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT) ?
		FL_t : FL_f;
}

BUILTIN("fixnum", fixnum)
{
	argcount(nargs, 1);
	value_t v = args[0];
	if(isfixnum(v))
		return v;
	void *p = ptr(v);
	if(iscprim(v))
		return fixnum(conv_to_int64(cp_data(p), cp_numtype(p)));
	if(iscvalue(v) && cp_numtype(p) == T_MPINT)
		return fixnum(mptov(*(mpint**)cv_data(p)));
	type_error("number", v);
}

BUILTIN("truncate", truncate)
{
	argcount(nargs, 1);
	if(isfixnum(args[0]))
		return args[0];
	if(iscprim(args[0])){
		cprim_t *cp = ptr(args[0]);
		void *data = cp_data(cp);
		numerictype_t nt = cp_numtype(cp);
		double d;
		if(nt == T_FLOAT)
			d = (double)*(float*)data;
		else if(nt == T_DOUBLE)
			d = *(double*)data;
		else
			return args[0];

		if(d > 0){
			if(d > (double)INT64_MAX)
				return args[0];
			return return_from_uint64((uint64_t)d);
		}
		if(d > (double)INT64_MAX || d < (double)INT64_MIN)
			return args[0];
		return return_from_int64((int64_t)d);
	}
	type_error("number", args[0]);
}

BUILTIN("vector-alloc", vector_alloc)
{
	size_t i, k, a;
	value_t f, v;
	if(nargs < 1)
		argcount(nargs, 1);
	i = tosize(args[0]);
	v = alloc_vector(i, 0);
	a = 1;
	for(k = 0; k < i; k++){
		f = a < nargs ? args[a] : FL_unspecified;
		vector_elt(v, k) = f;
		if((a = (a + 1) % nargs) < 1)
			a = 1;
	}
	return v;
}

BUILTIN("time-now", time_now)
{
	argcount(nargs, 0);
	USED(args);
	return mk_double(sec_realtime());
}

double
todouble(value_t a)
{
	if(isfixnum(a))
		return (double)numval(a);
	if(iscprim(a)){
		cprim_t *cp = ptr(a);
		numerictype_t nt = cp_numtype(cp);
		return conv_to_double(cp_data(cp), nt);
	}
	type_error("number", a);
}

BUILTIN("time->string", time_string)
{
	argcount(nargs, 1);
	double t = todouble(args[0]);
	char buf[64];
	timestring(t, buf, sizeof(buf));
	return string_from_cstr(buf);
}

BUILTIN("string->time", string_time)
{
	argcount(nargs, 1);
	char *ptr = tostring(args[0]);
	double t = parsetime(ptr);
	int64_t it = (int64_t)t;
	if((double)it == t && fits_fixnum(it))
		return fixnum(it);
	return mk_double(t);
}

BUILTIN("path-cwd", path_cwd)
{
	if(nargs > 1)
		argcount(nargs, 1);
	if(nargs == 0){
		char buf[1024];
		getcwd(buf, sizeof(buf));
		return string_from_cstr(buf);
	}
	char *ptr = tostring(args[0]);
	if(chdir(ptr))
		lerrorf(FL(IOError), "could not cd to %s", ptr);
	return FL_t;
}

BUILTIN("path-exists?", path_existsp)
{
	argcount(nargs, 1);
	char *path = tostring(args[0]);
	return access(path, F_OK) == 0 ? FL_t : FL_f;
}

BUILTIN("os-getenv", os_getenv)
{
	argcount(nargs, 1);
	char *name = tostring(args[0]);
	char *val = getenv(name);
	if(val == nil)
		return FL_f;
	if(*val == 0)
		return symbol_value(FL(emptystringsym));
	return cvalue_static_cstring(val);
}

BUILTIN("os-setenv", os_setenv)
{
	argcount(nargs, 2);
	char *name = tostring(args[0]);
	int result;
	if(args[1] == FL_f)
		result = unsetenv(name);
	else{
		char *val = tostring(args[1]);
		result = setenv(name, val, 1);
	}
	if(result != 0)
		lerrorf(FL(ArgError), "invalid environment variable");
	return FL_t;
}

BUILTIN("rand", rand)
{
	USED(args); USED(nargs);
#ifdef BITS64
	uint64_t x = genrand_uint64();
#else
	uint32_t x = genrand_uint32();
#endif
	return fixnum(x >> 3);
}

BUILTIN("rand-uint32", rand_uint32)
{
	USED(args); USED(nargs);
	return mk_uint32(genrand_uint32());
}

BUILTIN("rand-uint64", rand_uint64)
{
	USED(args); USED(nargs);
	return mk_uint64(genrand_uint64());
}

BUILTIN("rand-double", rand_double)
{
	USED(args); USED(nargs);
	return mk_double(genrand_double());
}

BUILTIN("rand-float", rand_float)
{
	USED(args); USED(nargs);
	return mk_float(genrand_double());
}

#define BUILTIN_(lname, cname) \
	BUILTIN(lname, cname) \
	{ \
		argcount(nargs, 1); \
		return mk_double(cname(todouble(args[0]))); \
	}

BUILTIN_("sqrt", sqrt)
BUILTIN_("exp", exp)
BUILTIN_("log", log)
BUILTIN_("log10", log10)
BUILTIN_("sin", sin)
BUILTIN_("cos", cos)
BUILTIN_("tan", tan)
BUILTIN_("asin", asin)
BUILTIN_("acos", acos)
BUILTIN_("atan", atan)
BUILTIN_("floor", floor)
BUILTIN_("ceiling", ceil)
BUILTIN_("sinh", sinh)
BUILTIN_("cosh", cosh)
BUILTIN_("tanh", tanh)

#undef BUILTIN_
#define BUILTIN_(lname, cname) \
	BUILTIN(lname, cname) \
	{ \
		argcount(nargs, 2); \
		return mk_double(cname(todouble(args[0]), todouble(args[1]))); \
	}

BUILTIN_("expt", pow)