shithub: sl

ref: 12c9d2fc728b51aa1eb9a70d0d331eb9464912d9
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];
	csl_v *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_arraylen(a));
	if(isvector(a))
		return size_wrap(vector_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 ? tofixnum(args[0]) : 0);
}

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

sl_purefn
BUILTIN("keyword?", keywordp)
{
	argcount(nargs, 1);
	return (issymbol(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 = 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);
	sl_sym *sym = tosymbol(args[0]);
	if(!isconstant(sym))
		sym->binding = args[1];
	return args[1];
}

BUILTIN("makunbound", makunbound)
{
	argcount(nargs, 1);
	sl_sym *sym = tosymbol(args[0]);
	if(!isconstant(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("constant?", constantp)
{
	argcount(nargs, 1);
	if(issymbol(args[0]))
		return isconstant((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("integer-valued?", integer_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("integer?", integerp)
{
	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("number", 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("number", v);
}

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

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("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);
	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 string_from_cstr(buf);
	}
	char *ptr = tostring(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 = tostring(args[0]);
	return access(path, F_OK) == 0 ? sl_t : sl_nil;
}

BUILTIN("delete-file", delete_file)
{
	argcount(nargs, 1);
	const char *path = tostring(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 = tostring(args[0]);
	char *val = getenv(name);
	if(val == nil)
		return sl_nil;
	return cvalue_static_cstring(val);
}

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