shithub: femtolisp

ref: 1b0eb3b4437a74231451a95225233fada1039876
dir: /builtins.c/

View raw version
/*
  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)
{
    value_t v;
    cons_t *c;
    argcount(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(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("sequence", a);
}

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

BUILTIN("exit", exit)
{
    if (nargs > 0)
        exit(tofixnum(args[0]));
    exit(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;
    }
    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(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];
    }
    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("number", args[0]);
}

double trunc(double x);

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)
{
    fixnum_t i;
    value_t f, v;
    if (nargs == 0)
        lerrorf(ArgError, "too few arguments");
    i = (fixnum_t)toulong(args[0]);
    if (i < 0)
        lerrorf(ArgError, "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(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);
    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(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)

extern void table_init(void);
extern void iostream_init(void);

void builtins_init(void)
{
    table_init();
    iostream_init();
}