ref: 75fa6d220de69bdb91954ea8cf942611b25214cb
dir: /src/builtins.c/
/*
Extra femtoLisp builtin functions
*/
#include "flisp.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)
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 = 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;
}
fl_purefn
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_nil;
}
fl_purefn
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_nil;
}
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);
}
_Noreturn
BUILTIN("raise", raise)
{
argcount(nargs, 1);
fl_raise(args[0]);
}
_Noreturn
BUILTIN("exit", exit)
{
if(nargs > 1)
argcount(nargs, 1);
fl_exit(nargs > 0 ? tofixnum(args[0]) : 0);
}
BUILTIN("symbol", symbol)
{
argcount(nargs, 1);
if(fl_unlikely(!fl_isstring(args[0])))
type_error("string", args[0]);
return symbol(cvalue_data(args[0]), true);
}
fl_purefn
BUILTIN("keyword?", keywordp)
{
argcount(nargs, 1);
return (issymbol(args[0]) && iskeyword((symbol_t*)ptr(args[0]))) ? FL_t : FL_nil;
}
fl_purefn
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_void;
}
BUILTIN("environment", environment)
{
USED(args);
argcount(nargs, 0);
value_t lst = FL_nil;
fl_gc_handle(&lst);
const char *k = nil;
symbol_t *v;
while(Tnext(FL(symtab), &k, (void**)&v)){
if(v->binding != UNBOUND && (v->flags & FLAG_KEYWORD) == 0)
lst = fl_cons(tagptr(v, TAG_SYM), lst);
}
fl_free_gc_handles(1);
return lst;
}
fl_purefn
BUILTIN("constant?", constantp)
{
argcount(nargs, 1);
if(issymbol(args[0]))
return isconstant((symbol_t*)ptr(args[0])) ? FL_t : FL_nil;
if(iscons(args[0])){
if(car_(args[0]) == FL_quote)
return FL_t;
return FL_nil;
}
return FL_t;
}
fl_purefn
BUILTIN("integer-valued?", integer_valuedp)
{
argcount(nargs, 1);
value_t v = args[0];
if(isfixnum(v) || ismpint(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_nil;
}
fl_purefn
BUILTIN("integer?", integerp)
{
argcount(nargs, 1);
value_t v = args[0];
return (isfixnum(v) || ismpint(v) ||
(iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ?
FL_t : FL_nil;
}
fl_purefn
BUILTIN("bignum?", bignump)
{
argcount(nargs, 1);
return ismpint(args[0]) ? FL_t : FL_nil;
}
BUILTIN("fixnum", fixnum)
{
argcount(nargs, 1);
value_t v = args[0];
if(isfixnum(v))
return v;
if(iscprim(v)){
void *p = ptr(v);
return fixnum(conv_to_int64(cp_data(p), cp_numtype(p)));
}
if(ismpint(v))
#ifdef BITS64
return fixnum(mptov(tompint(v)));
#else
return fixnum(mptoi(tompint(v)));
#endif
type_error("number", v);
}
BUILTIN("truncate", truncate)
{
argcount(nargs, 1);
value_t v = args[0];
if(isfixnum(v) || ismpint(v))
return v;
if(iscprim(v)){
cprim_t *cp = ptr(v);
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 v;
if(d > 0){
if(d > (double)INT64_MAX)
return v;
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", v);
}
BUILTIN("vector-alloc", vector_alloc)
{
if(nargs < 1)
argcount(nargs, 1);
size_t i = tosize(args[0]);
value_t v = alloc_vector(i, 0);
int a = 1;
for(size_t k = 0; k < i; k++){
value_t f = a < nargs ? args[a] : FL_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_uint64(nanosec_monotonic());
}
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);
}
if(ismpint(a))
return conv_to_double(cv_data(ptr(a)), T_MPINT);
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[4096];
if(getcwd(buf, sizeof(buf)) == nil)
lerrorf(FL_IOError, "could not get current dir");
return string_from_cstr(buf);
}
char *ptr = tostring(args[0]);
if(chdir(ptr) != 0)
lerrorf(FL_IOError, "could not cd to %s", ptr);
return FL_void;
}
BUILTIN("path-exists?", path_existsp)
{
argcount(nargs, 1);
const char *path = tostring(args[0]);
return access(path, F_OK) == 0 ? FL_t : FL_nil;
}
BUILTIN("delete-file", delete_file)
{
argcount(nargs, 1);
const char *path = tostring(args[0]);
if(remove(path) != 0)
lerrorf(FL_IOError, "could not remove %s", path);
return FL_void;
}
BUILTIN("os-getenv", os_getenv)
{
argcount(nargs, 1);
char *name = tostring(args[0]);
char *val = getenv(name);
if(val == nil)
return FL_nil;
return cvalue_static_cstring(val);
}
BUILTIN("os-setenv", os_setenv)
{
argcount(nargs, 2);
char *name = tostring(args[0]);
int result;
if(args[1] == FL_nil)
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;
}