shithub: femtolisp

ref: 267698bd3be39d182fa974697e3c34ec23dcefd7
dir: /builtins.c/

/*
  Extra femtoLisp builtin functions
*/

#include "llt.h"
#include "flisp.h"

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;
	int i = 0;

	while(1){
		lst = args[i++];
		if(i >= nargs)
			break;
		if(iscons(lst)){
			*pcdr = lst;
			c = (cons_t*)ptr(lst);
			while(iscons(c->cdr))
				c = (cons_t*)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(isvector(a))
		return fixnum(vector_size(a));
	if(a == FL_NIL)
		return fixnum(0);
	if(iscons(a))
		return fixnum(llength(a));
	if(iscprim(a)){
		cv = (cvalue_t*)ptr(a);
		if(cp_class(cv) == bytetype)
			return fixnum(1);
		if(cp_class(cv) == wchartype)
			return fixnum(u8_charlen(*(uint32_t*)cp_data(cv)));
	}
	if(iscvalue(a) && cv_class(ptr(a))->eltype != nil)
		return size_wrap(cvalue_arraylen(a));
	type_error("sequence", a);
}

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

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

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

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];
}

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;
	}
}

extern symbol_t *symtab;

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

extern value_t QUOTE;

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]) == 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((cprim_t*)ptr(v));
		if(nt < T_FLOAT)
			return FL_T;
		void *data = cp_data((cprim_t*)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((cprim_t*)ptr(v)) < T_FLOAT)) ?
		FL_T : FL_F;
}

BUILTIN("bignum?", bignump)
{
	argcount(nargs, 1);
	value_t v = args[0];
	return ((! isfixnum(v)) ||
			(iscprim(v) && cp_numtype((cprim_t*)ptr(v)) < T_FLOAT)) ?
		FL_T : FL_F;
}

BUILTIN("fixnum", fixnum)
{
	argcount(nargs, 1);
	if(isfixnum(args[0]))
		return args[0];
	if(iscprim(args[0])){
		cprim_t *cp = (cprim_t*)ptr(args[0]);
		return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp)));
	}
	type_error("number", args[0]);
}

BUILTIN("truncate", truncate)
{
	argcount(nargs, 1);
	if(isfixnum(args[0]))
		return args[0];
	if(iscprim(args[0])){
		cprim_t *cp = (cprim_t*)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)
{
	int i, k;
	value_t f, v;
	if(nargs < 1 || nargs > 2)
		argcount(nargs, 1);
	i = toulong(args[0]);
	if(i < 0)
		lerrorf(ArgError, "invalid size: %d", i);
	v = alloc_vector((unsigned)i, 0);
	f = nargs == 2 ? args[1] : FL_UNSPECIFIED;
	for(k = 0; k < i; k++)
		vector_elt(v, k) = f;
	return v;
}

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

static double
todouble(value_t a)
{
	if(isfixnum(a))
		return (double)numval(a);
	if(iscprim(a)){
		cprim_t *cp = (cprim_t*)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("time.fromstring", time_fromstring)
{
	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(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(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(ArgError, "invalid environment variable");
	return FL_T;
}

BUILTIN("rand", rand)
{
	USED(args); USED(nargs);
	uint64_t x = genrand_int63();
	fixnum_t r;
#ifdef BITS64
	r = x >> 3;
#else
	r = x >> (32+3);
#endif
	return fixnum(r);
}

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); \
		if(iscprim(args[0])){ \
			cprim_t *cp = (cprim_t*)ptr(args[0]); \
			numerictype_t nt = cp_numtype(cp); \
			if(nt == T_FLOAT) \
				return mk_float(cname##f(*(float*)cp_data(cp))); \
		} \
		return mk_double(cname(todouble(args[0]))); \
	}

BUILTIN_("sqrt", sqrt)
BUILTIN_("exp", exp)
BUILTIN_("log", log)
BUILTIN_("sin", sin)
BUILTIN_("cos", cos)
BUILTIN_("tan", tan)
BUILTIN_("asin", asin)
BUILTIN_("acos", acos)
BUILTIN_("atan", atan)