ref: d9d5b07e060c0c53f17a1428566049f6b1123f3c
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("nconc", "cons", lst);
}
}
*pcdr = lst;
return first;
}
BUILTIN("assq", assq)
{
argcount("assq", 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)
{
value_t v;
cons_t *c;
argcount("memq", nargs, 2);
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("length", nargs, 1);
value_t a = args[0];
cvalue_t *cv;
if (isvector(a)) {
return fixnum(vector_size(a));
}
else if (iscprim(a)) {
cv = (cvalue_t*)ptr(a);
if (cp_class(cv) == bytetype)
return fixnum(1);
else if (cp_class(cv) == wchartype)
return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
}
else if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
if (cv_class(cv)->eltype != nil)
return size_wrap(cvalue_arraylen(a));
}
else if (a == FL_NIL) {
return fixnum(0);
}
else if (iscons(a)) {
return fixnum(llength(a));
}
type_error("length", "sequence", a);
}
BUILTIN("raise", raise)
{
argcount("raise", nargs, 1);
fl_raise(args[0]);
}
BUILTIN("exit", exit)
{
if (nargs > 0)
exit(tofixnum(args[0], "exit"));
exit(0);
return FL_NIL;
}
BUILTIN("symbol", symbol)
{
argcount("symbol", nargs, 1);
if (!fl_isstring(args[0]))
type_error("symbol", "string", args[0]);
return symbol(cvalue_data(args[0]));
}
BUILTIN("keyword?", keywordp)
{
argcount("keyword?", nargs, 1);
return (issymbol(args[0]) &&
iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
}
BUILTIN("top-level-value", top_level_value)
{
argcount("top-level-value", nargs, 1);
symbol_t *sym = tosymbol(args[0], "top-level-value");
if (sym->binding == UNBOUND)
fl_raise(fl_list2(UnboundError, args[0]));
return sym->binding;
}
BUILTIN("set-top-level-value!", set_top_level_value)
{
argcount("set-top-level-value!", nargs, 2);
symbol_t *sym = tosymbol(args[0], "set-top-level-value!");
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("environment", 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("constant?", 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("integer-valued?", nargs, 1);
value_t v = args[0];
if (isfixnum(v)) {
return FL_T;
}
else 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("integer?", 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("fixnum", nargs, 1);
if (isfixnum(args[0])) {
return args[0];
}
else 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("fixnum", "number", args[0]);
}
double trunc(double x);
BUILTIN("truncate", truncate)
{
argcount("truncate", 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("truncate", "number", args[0]);
}
BUILTIN("vector.alloc", vector_alloc)
{
fixnum_t i;
value_t f, v;
if (nargs == 0)
lerrorf(ArgError, "vector.alloc: too few arguments");
i = (fixnum_t)toulong(args[0], "vector.alloc");
if (i < 0)
lerrorf(ArgError, "vector.alloc: invalid size");
v = alloc_vector((unsigned)i, 0);
if (nargs == 2)
f = args[1];
else
f = FL_UNSPECIFIED;
int k;
for(k=0; k < i; k++)
vector_elt(v,k) = f;
return v;
}
BUILTIN("time.now", time_now)
{
argcount("time.now", nargs, 0);
USED(args);
return mk_double(clock_now());
}
static double todouble(value_t a, char *fname)
{
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(fname, "number", a);
}
BUILTIN("time.string", time_string)
{
argcount("time.string", nargs, 1);
double t = todouble(args[0], "time.string");
char buf[64];
timestring(t, buf, sizeof(buf));
return string_from_cstr(buf);
}
BUILTIN("time.fromstring", time_fromstring)
{
argcount("time.fromstring", nargs, 1);
char *ptr = tostring(args[0], "time.fromstring");
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("path.cwd", nargs, 1);
if (nargs == 0) {
char buf[1024];
getcwd(buf, sizeof(buf));
return string_from_cstr(buf);
}
char *ptr = tostring(args[0], "path.cwd");
if (chdir(ptr))
lerrorf(IOError, "path.cwd: could not cd to %s", ptr);
return FL_T;
}
BUILTIN("path.exists?", path_existsp)
{
argcount("path.exists?", nargs, 1);
char *path = tostring(args[0], "path.exists?");
return access(path, F_OK) == 0 ? FL_T : FL_F;
}
BUILTIN("os.getenv", os_getenv)
{
argcount("os.getenv", nargs, 1);
char *name = tostring(args[0], "os.getenv");
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("os.setenv", nargs, 2);
char *name = tostring(args[0], "os.setenv");
int result;
if (args[1] == FL_F) {
result = unsetenv(name);
}
else {
char *val = tostring(args[1], "os.setenv");
result = setenv(name, val, 1);
}
if (result != 0)
lerrorf(ArgError, "os.setenv: invalid environment variable");
return FL_T;
}
BUILTIN("rand", rand)
{
USED(args); USED(nargs);
fixnum_t r;
#ifdef BITS64
r = ((((uint64_t)random())<<32) | random()) & 0x1fffffffffffffffLL;
#else
r = random() & 0x1fffffff;
#endif
return fixnum(r);
}
BUILTIN("rand.uint32", rand_uint32)
{
USED(args); USED(nargs);
uint32_t r = random();
#ifdef BITS64
return fixnum(r);
#else
return mk_uint32(r);
#endif
}
BUILTIN("rand.uint64", rand_uint64)
{
USED(args); USED(nargs);
uint64_t r = (((uint64_t)random())<<32) | random();
return mk_uint64(r);
}
BUILTIN("rand.double", rand_double)
{
USED(args); USED(nargs);
return mk_double(rand_double());
}
BUILTIN("rand.float", rand_float)
{
USED(args); USED(nargs);
return mk_float(rand_float());
}
#define BUILTIN_(lname, cname) \
BUILTIN(lname, cname) \
{ \
argcount(lname, 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], lname))); \
}
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)
extern void table_init(void);
extern void iostream_init(void);
void builtins_init(void)
{
table_init();
iostream_init();
}