#include "sl.h"#include "operators.h"#include "cvalues.h"#include "timefuncs.h"#include "table.h"#include "nan.h"#include "ieee754.h" #define DBL_MAXINT (1LL<<DBL_MANT_DIG)#define FLT_MAXINT (1<<FLT_MANT_DIG) usizellength(sl_v v){	usize n = 0;	while(iscons(v)){		n++;		v = cdr_(v);	}	return n;} static boolint_valued(double x){	union ieee754_double d;	double i;	d.d = modf(x, &i);	return d.ieee.exponent == 0 && d.ieee.mantissa0 == 0 && d.ieee.mantissa1 == 0;} 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){			bthrow(type_error(nil, "cons", lst));		}	}	*pcdr = lst;	return first;} sl_purefnBUILTIN("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_purefnBUILTIN("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];	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_f64(D_PINF);		n += llength(v);		return size_wrap(n);	}	if(isstr(a)){		bool err;		return size_wrap(u8_runelen(cvalue_data(a), cv_len(ptr(args[0])), &err));	}	if(isarr(a))		return size_wrap(cvalue_arrlen(a));	if(isvec(a))		return size_wrap(vec_size(a));	if(ishashtable(a)){		sl_htable *h = totable(a);		return size_wrap(h->num);	}	if(a == sl_nil)		return fixnum(0);	bthrow(type_error(nil, "sequence", a));} _NoreturnBUILTIN("raise", raise){	argcount(nargs, 1);	bthrow(sl_raise(args[0]));} _NoreturnBUILTIN("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 && isstr(args[0]))		name = args[0];	else		name = fn_builtin_str(args, nargs);	sl_v v = mk_sym(cvalue_data(name), true);	sl_sym *s = tosym(v);	if(s->binding == sl_t || s->binding == sl_nil)		return s->binding;	return v;} sl_purefnBUILTIN("keyword?", keywordp){	argcount(nargs, 1);	return (issym(args[0]) && iskeyword((sl_sym*)ptr(args[0]))) ? sl_t : sl_nil;} sl_purefnBUILTIN("top-level-value", top_level_value){	argcount(nargs, 1);	sl_sym *sym = tosym(args[0]);	if(sym->binding == sl_unbound)		bthrow(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)))		bthrow(const_error(args[0]));	sym->binding = args[1];	return args[1];} BUILTIN("makunbound", makunbound){	argcount(nargs, 1);	sl_sym *sym = tosym(args[0]);	if(sl_unlikely(isconst(sym)))		bthrow(const_error(args[0]));	sym->binding = sl_unbound;	return sl_void;} BUILTIN("environment", environment){	argcount(nargs, 0);	sl_v lst = sl_nil;	sl_gc_handle(&lst);	const char *k = nil;	sl_sym *v;	while(Tnext(slvm.symbols, &k, (void**)&v)){		if(v->binding == sl_unbound)			continue;		if((v->flags & FLAG_CONST) != 0)			continue;		lst = mk_cons(tagptr(v, TAG_SYM), lst);	}	sl_free_gc_handles(1);	return lst;} sl_purefnBUILTIN("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_purefnBUILTIN("int-valued?", int_valuedp){	argcount(nargs, 1);	sl_v v = args[0];	if(isfixnum(v) || isubnum(v))		return sl_t;	if(iscvalue(v)){		sl_numtype nt = cv_numtype(ptr(v));		if(nt < T_F32)			return sl_t;		void *data = cv_data(ptr(v));		if(nt == T_F32){			float f = *(float*)data;			if(isnan(f))				return sl_nil;			if(f < 0)				f = -f;			if(f <= FLT_MAXINT && int_valued(f))				return sl_t;		}else{			assert(nt == T_F64);			double d = *(double*)data;			if(isnan(d))				return sl_nil;			if(d < 0)				d = -d;			if(d <= DBL_MAXINT && int_valued(d))				return sl_t;		}	}	return sl_nil;} sl_purefnBUILTIN("int?", intp){	argcount(nargs, 1);	sl_v v = args[0];	return (isfixnum(v) || isubnum(v) ||			(iscvalue(v) && cv_numtype(ptr(v)) < T_F32)) ?		sl_t : sl_nil;} sl_purefnBUILTIN("bignum?", bignump){	argcount(nargs, 1);	return isbignum(args[0]) ? sl_t : sl_nil;} sl_purefnBUILTIN("ptr?", ptrp){	argcount(nargs, 1);	sl_v v = args[0];	if(isubnum(v))		return ubnumtype(v) == T_P32 || ubnumtype(v) == T_P64 ? sl_t : sl_nil;	if(iscvalue(v)){		sl_cv *p = ptr(v);		return cv_numtype(p) == T_P32 || cv_numtype(p) == T_P64 ? sl_t : sl_nil;	}	return sl_nil;} BUILTIN("fixnum", fixnum){	if(nargs == 0)		return fixnum(0);	argcount(nargs, 1);	sl_v v = args[0];	if(isubnum(v))		return fixnum(ubnumval(v));	if(iscvalue(v)){		sl_cv *p = ptr(v);		return fixnum(conv_to_s64(v, cv_data(p), cv_numtype(p)));	}	if(isfixnum(v))		return v;	bthrow(type_error(nil, "num", v));} BUILTIN("truncate", truncate){	argcount(nargs, 1);	sl_v v = args[0];	if(isfixnum(v) || isubnum(v))		return v;	if(iscvalue(v)){		sl_cv *cv = ptr(v);		void *data = cv_data(cv);		sl_numtype nt = cv_numtype(cv);		double d;		if(valid_numtype(nt)){			if(nt == T_F32)				d = *(float*)data;			else if(nt == T_F64)				d = *(double*)data;			else				return v;			d = trunc(d);			if(isnan(d) || isinf(d))				return v;			s64int s = trunc(d);			if(s < FIXNUM_MIN || s > FIXNUM_MAX)				return mk_bignum(vtomp(s, nil));			return fixnum(s);		}	}	bthrow(type_error(nil, "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("copy-vec", copy_vec){	argcount(nargs, 1);	sl_v v = args[0], v0;	if(sl_unlikely(!isvec(v) || isstruct(v)))		bthrow(type_error(nil, "vec", v));	v0 = alloc_vec(vec_size(v), false);	v = args[0]; // gc	memcpy(&vec_elt(v0, 0), &vec_elt(v, 0), vec_size(v0)*sizeof(sl_v));	return v0;} BUILTIN("time-now", time_now){	argcount(nargs, 0);	return mk_f64(sec_realtime());} BUILTIN("nanoseconds-monotonic", nanoseconds_monotonic){	argcount(nargs, 0);	return mk_u64(nanosec_monotonic());} doubletodouble(sl_v a){	if(isfixnum(a))		return numval(a);	if(isubnum(a))		return ubnumval(a);	if(iscvalue(a)){		sl_cv *cv = ptr(a);		sl_numtype nt = cv_numtype(cv);		return conv_to_double(a, cv_data(cv), nt);	}	bthrow(type_error(nil, "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);	return int_valued(t) ? mk_s64(t) : mk_f64(t);} 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)		bthrow(lerrorf(sl_errarg, "invalid environment variable"));	return sl_t;}