shithub: sl

ref: a70379d7e4b822f532fb0a8ccdd1624a90b64a68
dir: /src/builtins.c/

#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "timefuncs.h"
#include "table.h"
#include "nan.h"

#define DBL_MAXINT (1LL<<DBL_MANT_DIG)
#define FLT_MAXINT (1<<FLT_MANT_DIG)

usize
llength(sl_v v)
{
	usize n = 0;
	while(iscons(v)){
		n++;
		v = cdr_(v);
	}
	return n;
}

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

	sl_v lst, first = sl_nil;
	sl_v *pcdr = &first;
	sl_cons *c;
	int 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 != sl_nil)
			type_error("cons", lst);
	}
	*pcdr = lst;
	return first;
}

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

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

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

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

	sl_v v;
	sl_cons *c;
	for(v = args[1]; iscons(v); v = c->cdr){
		if((c = ptr(v))->car == args[0])
			return v;
	}
	return sl_nil;
}

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

	sl_v a = args[0];
	sl_cv *cv;

	if(iscons(a)){
		usize n = 0;
		sl_v 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) == sl_bytetype)
			return fixnum(1);
		if(cp_class(cv) == sl_runetype)
			return fixnum(runelen(*(Rune*)cp_data(cv)));
	}
	if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
		return size_wrap(cvalue_arrlen(a));
	if(isvec(a))
		return size_wrap(vec_size(a));
	if(ishashtable(a)){
		sl_htable *h = totable(a);
		void **t = h->table;
		usize sz = h->size;
		usize n = 0;
		for(usize i = 0; i < sz; i += 2){
			if(t[i+1] != HT_NOTFOUND)
				n++;
		}
		return size_wrap(n);
	}
	if(a == sl_nil)
		return fixnum(0);
	type_error("sequence", a);
}

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

_Noreturn
BUILTIN("exit", exit)
{
	if(nargs > 1)
		argcount(nargs, 1);
	sl_exit((nargs > 0 && args[0] != sl_nil) ? tostr(args[0]) : nil);
}

BUILTIN("sym", sym)
{
	if(nargs < 1)
		argcount(nargs, 1);
	sl_v name;
	if(nargs == 1 && sl_isstr(args[0]))
		name = args[0];
	else
		name = fn_builtin_str(args, nargs);
	return mk_sym(cvalue_data(name), true);
}

sl_purefn
BUILTIN("keyword?", keywordp)
{
	argcount(nargs, 1);
	return (issym(args[0]) && iskeyword((sl_sym*)ptr(args[0]))) ? sl_t : sl_nil;
}

sl_purefn
BUILTIN("top-level-value", top_level_value)
{
	argcount(nargs, 1);
	sl_sym *sym = tosym(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);
	sl_sym *sym = tosym(args[0]);
	if(sl_unlikely(isconst(sym)))
		const_error(sym);
	sym->binding = args[1];
	return args[1];
}

BUILTIN("makunbound", makunbound)
{
	argcount(nargs, 1);
	sl_sym *sym = tosym(args[0]);
	if(sl_unlikely(isconst(sym)))
		const_error(sym);
	sym->binding = UNBOUND;
	return sl_void;
}

BUILTIN("environment", environment)
{
	USED(args);
	argcount(nargs, 0);
	sl_v lst = sl_nil;
	sl_gc_handle(&lst);
	const char *k = nil;
	sl_sym *v;
	while(Tnext(slg.symbols, &k, (void**)&v)){
		if(v->binding != UNBOUND && (v->flags & FLAG_KEYWORD) == 0)
			lst = mk_cons(tagptr(v, TAG_SYM), lst);
	}
	sl_free_gc_handles(1);
	return lst;
}

sl_purefn
BUILTIN("const?", constp)
{
	argcount(nargs, 1);
	if(issym(args[0]))
		return isconst((sl_sym*)ptr(args[0])) ? sl_t : sl_nil;
	if(iscons(args[0])){
		if(car_(args[0]) == sl_quote)
			return sl_t;
		return sl_nil;
	}
	return sl_t;
}

sl_purefn
BUILTIN("int-valued?", int_valuedp)
{
	argcount(nargs, 1);
	sl_v v = args[0];
	if(isfixnum(v) || ismp(v))
		return sl_t;
	if(iscprim(v)){
		sl_numtype nt = cp_numtype(ptr(v));
		if(nt < T_FLOAT)
			return sl_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)(s32int)f == f)
				return sl_t;
		}else{
			assert(nt == T_DOUBLE);
			double d = *(double*)data;
			if(d < 0)
				d = -d;
			if(d <= DBL_MAXINT && (double)(s64int)d == d)
				return sl_t;
		}
	}
	return sl_nil;
}

sl_purefn
BUILTIN("int?", intp)
{
	argcount(nargs, 1);
	sl_v v = args[0];
	return (isfixnum(v) || ismp(v) ||
			(iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
		sl_t : sl_nil;
}

sl_purefn
BUILTIN("bignum?", bignump)
{
	argcount(nargs, 1);
	return ismp(args[0]) ? sl_t : sl_nil;
}

BUILTIN("fixnum", fixnum)
{
	argcount(nargs, 1);
	sl_v v = args[0];
	if(isfixnum(v))
		return v;
	if(iscprim(v)){
		void *p = ptr(v);
		return fixnum(conv_to_s64(cp_data(p), cp_numtype(p)));
	}
	if(ismp(v))
#ifdef BITS64
		return fixnum(mptov(tomp(v)));
#else
		return fixnum(mptoi(tomp(v)));
#endif
	type_error("num", v);
}

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

		if(d > 0){
			if(d > (double)INT64_MAX)
				return v;
			return return_from_u64((u64int)d);
		}
		if(d > (double)INT64_MAX || d < (double)INT64_MIN)
			return args[0];
		return return_from_s64((s64int)d);
	}
	type_error("num", v);
}

BUILTIN("vec-alloc", vec_alloc)
{
	if(nargs < 1)
		argcount(nargs, 1);
	usize i = tosize(args[0]);
	sl_v v = alloc_vec(i, 0);
	int a = 1;
	for(usize k = 0; k < i; k++){
		sl_v f = a < nargs ? args[a] : sl_void;
		vec_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());
}

BUILTIN("nanoseconds-monotonic", nanoseconds_monotonic)
{
	argcount(nargs, 0);
	USED(args);
	return mk_u64(nanosec_monotonic());
}

double
todouble(sl_v a)
{
	if(isfixnum(a))
		return (double)numval(a);
	if(iscprim(a)){
		sl_cprim *cp = ptr(a);
		sl_numtype nt = cp_numtype(cp);
		return conv_to_double(cp_data(cp), nt);
	}
	if(ismp(a))
		return conv_to_double(cv_data(ptr(a)), T_MP);
	type_error("num", a);
}

BUILTIN("time->str", time_str)
{
	argcount(nargs, 1);
	double t = todouble(args[0]);
	char buf[64];
	timestr(t, buf, sizeof(buf));
	return str_from_cstr(buf);
}

BUILTIN("str->time", str_time)
{
	argcount(nargs, 1);
	char *ptr = tostr(args[0]);
	double t = parsetime(ptr);
	s64int it = (s64int)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[4096];
		if(getcwd(buf, sizeof(buf)) == nil)
			lerrorf(sl_errio, "could not get current dir");
		return str_from_cstr(buf);
	}
	char *ptr = tostr(args[0]);
	if(chdir(ptr) != 0)
		lerrorf(sl_errio, "could not cd to %s", ptr);
	return sl_void;
}

BUILTIN("path-exists?", path_existsp)
{
	argcount(nargs, 1);
	const char *path = tostr(args[0]);
	return access(path, F_OK) == 0 ? sl_t : sl_nil;
}

BUILTIN("delete-file", delete_file)
{
	argcount(nargs, 1);
	const char *path = tostr(args[0]);
	if(remove(path) != 0)
		lerrorf(sl_errio, "could not remove %s", path);
	return sl_void;
}

BUILTIN("os-getenv", os_getenv)
{
	argcount(nargs, 1);
	char *name = tostr(args[0]);
	char *val = getenv(name);
	if(val == nil)
		return sl_nil;
	return cvalue_static_cstr(val);
}

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