ref: 14c196a5da48284123d615418c80b6fbc87d7f46
dir: /builtins.c/
/* Extra femtoLisp builtin functions */ #include "flisp.h" #include "operators.h" #include "cvalues.h" #include "timefuncs.h" #include "random.h" #define DBL_MAXINT (1LL<<53) #define FLT_MAXINT (1<<24) 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; uint32_t 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; } 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)){ 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 fixnum(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)); type_error("sequence", a); } BUILTIN("raise", raise) { argcount(nargs, 1); fl_raise(args[0]); } BUILTIN("exit", exit) { if(nargs > 1) argcount(nargs, 1); fl_exit(nargs > 0 ? tofixnum(args[0]) : 0); } BUILTIN("symbol", symbol) { argcount(nargs, 1); if(__unlikely(!fl_isstring(args[0]))) type_error("string", args[0]); return symbol(cvalue_data(args[0]), true); } 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]; } BUILTIN("makunbound", makunbound) { argcount(nargs, 1); symbol_t *sym = tosymbol(args[0]); if(!isconstant(sym)) sym->binding = UNBOUND; return FL(t); } 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; } } BUILTIN("environment", environment) { USED(args); argcount(nargs, 0); value_t lst = FL(Nil); fl_gc_handle(&lst); global_env_list(FL(symtab), &lst); fl_free_gc_handles(1); return lst; } 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]) == FL(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(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(f); } BUILTIN("integer?", integerp) { argcount(nargs, 1); value_t v = args[0]; return (isfixnum(v) || (iscprim(v) && cp_numtype(ptr(v)) < T_FLOAT)) ? FL(t) : FL(f); } BUILTIN("bignum?", bignump) { argcount(nargs, 1); value_t v = args[0]; return (iscvalue(v) && cp_numtype(ptr(v)) == T_MPINT) ? FL(t) : FL(f); } BUILTIN("fixnum", fixnum) { argcount(nargs, 1); value_t v = args[0]; if(isfixnum(v)) return v; void *p = ptr(v); if(iscprim(v)) return fixnum(conv_to_int64(cp_data(p), cp_numtype(p))); if(iscvalue(v) && cp_numtype(p) == T_MPINT) return fixnum(mptov(*(mpint**)cv_data(p))); type_error("number", v); } BUILTIN("truncate", truncate) { argcount(nargs, 1); if(isfixnum(args[0])) return args[0]; if(iscprim(args[0])){ cprim_t *cp = 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) { size_t i, k, a; value_t f, v; if(nargs < 1) argcount(nargs, 1); i = tosize(args[0]); v = alloc_vector(i, 0); a = 1; for(k = 0; k < i; k++){ f = a < nargs ? args[a] : FL(unspecified); 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()); } 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); } 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[1024]; getcwd(buf, sizeof(buf)); return string_from_cstr(buf); } char *ptr = tostring(args[0]); if(chdir(ptr)) lerrorf(FL(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(FL(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(FL(ArgError), "invalid environment variable"); return FL(t); } BUILTIN("rand", rand) { USED(args); USED(nargs); #ifdef BITS64 uint64_t x = genrand_uint64(); #else uint32_t x = genrand_uint32(); #endif return fixnum(x >> 3); } 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); \ return mk_double(cname(todouble(args[0]))); \ } BUILTIN_("sqrt", sqrt) BUILTIN_("exp", exp) BUILTIN_("log", log) BUILTIN_("log10", log10) BUILTIN_("sin", sin) BUILTIN_("cos", cos) BUILTIN_("tan", tan) BUILTIN_("asin", asin) BUILTIN_("acos", acos) BUILTIN_("atan", atan) BUILTIN_("floor", floor) BUILTIN_("ceiling", ceil) BUILTIN_("sinh", sinh) BUILTIN_("cosh", cosh) BUILTIN_("tanh", tanh) #undef BUILTIN_ #define BUILTIN_(lname, cname) \ BUILTIN(lname, cname) \ { \ argcount(nargs, 2); \ return mk_double(cname(todouble(args[0]), todouble(args[1]))); \ } BUILTIN_("expt", pow)