ref: b78c9edfb4e91efa4aa61e09feaf3da4848342b0
dir: /src/cvalues.c/
#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "types.h"
#include "io.h"
#include "equal.h"
enum {
MAX_INL_SIZE = 384,
CVALUE_NWORDS = sizeof(sl_cv)/sizeof(sl_v),
CV_OWNED = 1<<0,
};
#define owned(cv) ((uintptr)(cv)->type & CV_OWNED)
#define isinlined(cv) ((cv)->data == (cv)->_space)
sl_type *unboxedtypes[T_UNBOXED_NUM];
sl_v unboxedtypesyms[T_UNBOXED_NUM];
static void cvalue_init(sl_type *type, sl_v v, void *dest);
void
add_finalizer(sl_cv *cv)
{
if(slg.nfinalizers == slg.maxfinalizers){
slg.maxfinalizers *= 2;
slg.finalizers = MEM_REALLOC(slg.finalizers, slg.maxfinalizers*sizeof(slg.finalizers));
assert(slg.finalizers != nil);
}
slg.finalizers[slg.nfinalizers++] = cv;
}
// remove dead objects from finalization list in-place
void
sweep_finalizers(void)
{
sl_cv **lst = slg.finalizers;
usize n = 0, ndel = 0, l = slg.nfinalizers;
sl_cv *tmp;
#define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1)
if(l == 0)
return;
do{
tmp = lst[n];
if(isforwarded((sl_v)tmp)){
// object is alive
lst[n] = ptr(forwardloc((sl_v)tmp));
n++;
}else{
sl_type *t = cv_class(tmp);
if(t->vtable != nil && t->vtable->finalize != nil)
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
if(!isinlined(tmp) && owned(tmp))
MEM_FREE(cv_data(tmp));
ndel++;
}
}while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel]));
slg.nfinalizers -= ndel;
slg.malloc_pressure = 0;
}
// compute the size of the metadata object for a cvalue
static usize
cv_nwords(sl_cv *cv)
{
if(!isinlined(cv))
return CVALUE_NWORDS;
usize n = cv_len(cv);
if(cv_isstr(cv))
n++;
return CVALUE_NWORDS + NWORDS(n);
}
void
cv_autorelease(sl_cv *cv)
{
cv->type = (sl_type*)(((uintptr)cv->type) | CV_OWNED);
add_finalizer(cv);
}
sl_v
cvalue_(sl_type *type, usize sz, bool nofinalize)
{
assert(type != nil);
bool str = false;
if(type->eltype == sl_utf8type){
if(sz == 0)
return sl_emptystr;
sz++;
str = true;
}
sl_cv *pcv;
if(sz <= MAX_INL_SIZE){
usize nw = CVALUE_NWORDS + NWORDS(sz);
pcv = alloc_words(nw);
pcv->type = type;
pcv->data = pcv->_space;
if(!nofinalize && type->vtable != nil && type->vtable->finalize != nil)
add_finalizer(pcv);
}else{
if(slg.malloc_pressure > ALLOC_LIMIT_TRIGGER)
sl_gc(false);
pcv = alloc_words(CVALUE_NWORDS);
pcv->type = type;
pcv->data = MEM_ALLOC(sz);
cv_autorelease(pcv);
slg.malloc_pressure += sz;
}
if(str)
((char*)pcv->data)[--sz] = '\0';
pcv->len = sz;
return tagptr(pcv, TAG_CVALUE);
}
// this effectively dereferences a pointer
// just like *p in C, it only removes a level of indirection from the type,
// it doesn't copy any data.
// this method of creating a cvalue only allocates metadata.
// ptr is user-managed; we don't autorelease it unless the
// user explicitly calls (autorelease ) on the result of this function.
// 'parent' is an optional cvalue that this pointer is known to point
// into; NIL if none.
sl_v
cvalue_from_ref(sl_type *type, void *ptr, usize sz)
{
sl_cv *pcv;
assert(type != nil);
assert(ptr != nil);
pcv = alloc_words(CVALUE_NWORDS);
pcv->data = ptr;
pcv->len = sz;
pcv->type = type;
return tagptr(pcv, TAG_CVALUE);
}
sl_v
cvalue_str(usize sz)
{
if(sz == 0)
return sl_emptystr;
return cvalue(sl_strtype, sz);
}
sl_v
cvalue_static_cstr(const char *str)
{
if(*str == 0)
return sl_emptystr;
return cvalue_from_ref(sl_strtype, (char*)str, strlen(str));
}
sl_v
str_from_cstrn(char *str, usize n)
{
sl_v v = cvalue_str(n);
memcpy(cvalue_data(v), str, n);
return v;
}
sl_v
str_from_cstr(char *str)
{
return str_from_cstrn(str, strlen(str));
}
bool
sl_isstr(sl_v v)
{
return iscvalue(v) && cv_isstr(ptr(v));
}
// convert to malloc representation (fixed address)
void
cv_pin(sl_cv *cv)
{
if(!isinlined(cv))
return;
usize sz = cv_len(cv);
if(cv_isstr(cv))
sz++;
void *data = MEM_ALLOC(sz);
memcpy(data, cv_data(cv), sz);
cv->data = data;
cv_autorelease(cv);
}
static void
cvalue_rune_init(sl_type *type, sl_v a, void *dest)
{
Rune r;
USED(type);
if(isfixnum(a))
r = numval(a);
else if(isrune(a))
r = torune(a);
else if(iscvalue(a))
r = conv_to_u32(a, cv_data(ptr(a)), cv_numtype(ptr(a)));
else if(isubnum(a)){
sl_fx v = ubnumval(a);
r = conv_to_u32(a, &v, ubnumtype(a));
}else
cthrow(type_error("num", a), type);
*((Rune*)dest) = r;
}
#define num_init(ctype, cnvt, tag) \
static void \
cvalue_##ctype##_init(sl_type *type, sl_v a, void *dest) \
{ \
ctype n; \
USED(type); \
if(isfixnum(a)){ \
n = (ctype)numval(a); \
}else if(isubnum(a)){ \
sl_fx v = ubnumval(a); \
n = (ctype)conv_to_##cnvt(a, &v, ubnumtype(a)); \
}else if(iscvalue(a)){ \
n = (ctype)conv_to_##cnvt(a, cv_data(ptr(a)), cv_numtype(ptr(a))); \
}else \
cthrow(type_error("num", a), type); \
*((ctype*)dest) = n; \
}
num_init(s8int, s32, T_S8)
num_init(u8int, u32, T_U8)
num_init(s16int, s32, T_S16)
num_init(u16int, u32, T_U16)
num_init(s32int, s32, T_S32)
num_init(u32int, u32, T_U32)
num_init(s64int, s64, T_S64)
num_init(u64int, u64, T_U64)
num_init(uintptr, ptr, T_PTR)
num_init(float, double, T_FLOAT)
num_init(double, double, T_DOUBLE)
BUILTIN("rune", rune)
{
if(nargs == 0){
PUSH(fixnum(0));
args = sl.sp-1;
}else
argcount(nargs, 1);
Rune r;
cvalue_rune_init(sl_runetype, args[0], &r);
return mk_rune(r);
}
#define num_ctor_init(typenam, ctype, tag) \
static \
BUILTIN(#typenam, typenam) \
{ \
if(nargs == 0){ \
PUSH(fixnum(0)); \
args = sl.sp-1; \
}else \
argcount(nargs, 1); \
sl_v v = cvalue(sl_##typenam##type, sizeof(ctype)); \
cvalue_##ctype##_init(sl_##typenam##type, args[0], cvalue_data(v)); \
return v; \
}
#define num_ctor_init_unboxed(typenam, ctype, tag) \
static \
BUILTIN(#typenam, typenam) \
{ \
if(nargs == 0){ \
PUSH(fixnum(0)); \
args = sl.sp-1; \
}else \
argcount(nargs, 1); \
sl_v v; \
ctype n; \
cvalue_##ctype##_init(sl_##typenam##type, args[0], &n); \
if(tag < T_UNBOXED_NUM && \
(sizeof(n) < sizeof(sl_v) || fits_bits(n, UNBOXED_BITS-1))){ \
v = (sl_v)n<<TAG_EXT_BITS | tag<<TAG_UBNUM_SHIFT | TAG_UNBOXED; \
}else{ \
v = cvalue(sl_##typenam##type, sizeof(n)); \
*(ctype*)cvalue_data(v) = n; \
} \
return v; \
}
#define num_ctor_ctor(typenam, ctype, tag) \
sl_v \
mk_##typenam(ctype n) \
{ \
sl_v v = cvalue(sl_##typenam##type, sizeof(n)); \
*(ctype*)cvalue_data(v) = n; \
return v; \
}
#define num_ctor_ctor_unboxed(typenam, ctype, tag) \
sl_constfn \
sl_v \
mk_##typenam(ctype n) \
{ \
sl_v v; \
if(tag < T_UNBOXED_NUM && \
(sizeof(n) < sizeof(sl_v) || fits_bits(n, UNBOXED_BITS-1))){ \
v = (sl_v)n<<TAG_EXT_BITS | tag<<TAG_UBNUM_SHIFT | TAG_UNBOXED; \
}else{ \
v = cvalue(sl_##typenam##type, sizeof(n)); \
*(ctype*)cvalue_data(v) = n; \
} \
return v; \
}
#define num_ctor(typenam, ctype, tag) \
num_ctor_init(typenam, ctype, tag) \
num_ctor_ctor(typenam, ctype, tag)
#define num_ctor_unboxed(typenam, ctype, tag) \
num_ctor_init_unboxed(typenam, ctype, tag) \
num_ctor_ctor_unboxed(typenam, ctype, tag)
num_ctor_unboxed(s8, s8int, T_S8)
num_ctor_unboxed(u8, u8int, T_U8)
num_ctor_unboxed(s16, s16int, T_S16)
num_ctor_unboxed(u16, u16int, T_U16)
num_ctor_unboxed(s32, s32int, T_S32)
num_ctor_unboxed(u32, u32int, T_U32)
num_ctor_unboxed(s64, s64int, T_S64)
num_ctor_unboxed(u64, u64int, T_U64)
num_ctor_unboxed(ptr, uintptr, T_PTR)
num_ctor(float, float, T_FLOAT)
num_ctor(double, double, T_DOUBLE)
num_ctor_init(utf8, u8int, T_U8)
static void
cvalue_bignum_init(sl_type *type, sl_v a, void *dest)
{
mpint *n;
USED(type);
if(isfixnum(a))
n = vtomp(numval(a), nil);
else if(isubnum(a)){
uintptr v = ubnumval(a);
n = conv_to_bignum(a, &v, ubnumtype(a));
}else if(iscvalue(a)){
sl_cv *cv = ptr(a);
void *p = cv_data(cv);
n = conv_to_bignum(a, p, cv_numtype(cv));
}else
cthrow(type_error("num", a), type);
*((mpint**)dest) = n;
}
BUILTIN("bignum", bignum)
{
if(nargs == 0){
PUSH(fixnum(0));
args = sl.sp-1;
}else
argcount(nargs, 1);
sl_v cv = cvalue(sl_bignumtype, sizeof(mpint*));
cvalue_bignum_init(sl_bignumtype, args[0], cvalue_data(cv));
return cv;
}
sl_v
mk_bignum(mpint *n)
{
sl_v cv = cvalue(sl_bignumtype, sizeof(mpint*));
*(mpint**)cvalue_data(cv) = n;
return cv;
}
static void
free_bignum(sl_v self)
{
mpint **s = value2c(mpint**, self);
if(*s != mpzero && *s != mpone && *s != mptwo)
mpfree(*s);
}
static sl_cvtable bignum_vtable = { nil, nil, free_bignum, nil };
sl_constfn
sl_v
size_wrap(usize sz)
{
if(sizeof(usize) == 8)
return fits_fixnum(sz) ? fixnum(sz): mk_u64(sz);
else
return fits_fixnum(sz) ? fixnum(sz): mk_u32(sz);
}
usize
tosize(sl_v n)
{
if(isfixnum(n))
return numval(n);
if(isubnum(n))
return ubnumval(n);
if(iscvalue(n)){
sl_cv *cv = ptr(n);
if(sizeof(usize) > 4)
return conv_to_u64(n, cv_data(cv), cv_numtype(cv));
return conv_to_u32(n, cv_data(cv), cv_numtype(cv));
}
cthrow(type_error("num", n), n);
}
soffset
tooffset(sl_v n)
{
if(isfixnum(n))
return numval(n);
if(isubnum(n))
return ubnumval(n);
if(iscvalue(n)){
sl_cv *cv = ptr(n);
if(sizeof(usize) > 4)
return conv_to_s64(n, cv_data(cv), cv_numtype(cv));
return conv_to_s32(n, cv_data(cv), cv_numtype(cv));
}
cthrow(type_error("num", n), n);
}
bool
isarr(sl_v v)
{
return iscvalue(v) && cv_class(ptr(v))->eltype != nil;
}
static usize
predict_arrlen(sl_v arg)
{
if(isvec(arg))
return vec_size(arg);
if(iscons(arg))
return llength(arg);
if(arg == sl_nil)
return 0;
if(isarr(arg))
return cvalue_arrlen(arg);
return 1;
}
void
cvalue_arr_init(sl_type *ft, sl_v arg, void *dest)
{
sl_v type = ft->type;
usize elsize, i, cnt, sz;
sl_type *eltype = ft->eltype;
elsize = ft->elsz;
cnt = predict_arrlen(arg);
if(iscons(cdr_(cdr_(type)))){
usize tc = tosize(car_(cdr_(cdr_(type))));
if(tc != cnt)
cthrow(lerrorf(sl_errarg, "size mismatch"), ft);
}
sz = elsize * cnt;
if(isvec(arg)){
assert(cnt <= vec_size(arg));
for(i = 0; i < cnt; i++){
cvalue_init(eltype, vec_elt(arg, i), dest);
dest = (char*)dest + elsize;
}
return;
}
if(iscons(arg) || arg == sl_nil){
i = 0;
while(iscons(arg)){
if(i == cnt){
i++;
break;
} // trigger error
cvalue_init(eltype, car_(arg), dest);
i++;
dest = (char*)dest + elsize;
arg = cdr_(arg);
}
if(i != cnt)
cthrow(lerrorf(sl_errarg, "size mismatch"), ft);
return;
}
if(iscvalue(arg)){
sl_cv *cv = ptr(arg);
if(isarr(arg)){
sl_type *aet = cv_class(cv)->eltype;
if(aet == eltype){
if(cv_len(cv) == sz)
memcpy(dest, cv_data(cv), sz);
else
cthrow(lerrorf(sl_errarg, "size mismatch"), ft);
return;
}else{
// TODO: initialize array from different type elements
cthrow(lerrorf(sl_errarg, "element type mismatch"), ft);
}
}
}
if(cnt == 1)
cvalue_init(eltype, arg, dest);
cthrow(type_error("sequence", arg), ft);
}
BUILTIN("arr", arr)
{
usize elsize, cnt, sz;
sl_v arg;
if(nargs < 1)
argcount(nargs, 1);
cnt = nargs - 1;
sl_type *type = get_arr_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
sl_v cv = cvalue(type, sz);
char *dest = cvalue_data(cv);
int i;
FOR_ARGS(i, 1, arg, args){
if(!sl_isnum(arg) && type->eltype != sl_runetype)
bthrow(type_error("num", arg));
cvalue_init(type->eltype, arg, dest);
dest += elsize;
}
return cv;
}
BUILTIN("arr-alloc", arr_alloc)
{
usize elsize, sz;
long i, cnt, a;
if(nargs < 3)
argcount(nargs, 3);
cnt = tosize(args[1]);
if(cnt < 0)
bthrow(lerrorf(sl_errarg, "invalid size: %"PRIu64, (u64int)cnt));
sl_type *type = get_arr_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
sl_v cv = cvalue(type, sz);
char *dest = cvalue_data(cv);
a = 2;
for(i = 0; i < cnt; i++){
sl_v arg = args[a];
if(!sl_isnum(arg))
bthrow(type_error("num", arg));
cvalue_init(type->eltype, arg, dest);
dest += elsize;
if((a = (a + 1) % nargs) < 2)
a = 2;
}
return cv;
}
// NOTE: v must be an array
usize
cvalue_arrlen(sl_v v)
{
sl_cv *cv = ptr(v);
return cv_len(cv)/cv_class(cv)->elsz;
}
usize
ctype_sizeof(sl_v type)
{
sl_sym *s;
if(issym(type) &&
(s = ptr(type)) != nil &&
(valid_numtype(s->numtype) || type == sl_runesym))
return s->size;
if(iscons(type)){
sl_v hed = car_(type);
if(hed == sl_arrsym){
sl_v t = car(cdr_(type));
if(!iscons(cdr_(cdr_(type))))
cthrow(lerrorf(sl_errarg, "incomplete type"), type);
sl_v n = car_(cdr_(cdr_(type)));
usize sz = tosize(n);
return sz * ctype_sizeof(t);
}
}
cthrow(lerrorf(sl_errarg, "invalid c type"), type);
}
// get pointer and size for any plain-old-data value
void
to_sized_ptr(sl_v v, u8int **pdata, usize *psz, uintptr *u)
{
if(isubnum(v)){
*u = ubnumval(v);
*pdata = (u8int*)u;
*psz = unboxedtypes[ubnumtype(v)]->size;
return;
}
if(isrune(v)){
Rune r = torune(v);
*pdata = (u8int*)u;
*psz = runetochar((char*)u, &r);
return;
}
if(iscvalue(v)){
sl_cv *pcv = ptr(v);
ios *x;
if(isio(v) && (x = value2c(ios*, v))->bm == bm_mem){
*pdata = x->buf;
*psz = x->size;
return;
}
if(cv_isPOD(pcv)){
*pdata = cv_data(pcv);
*psz = cv_len(pcv);
return;
}
}
cthrow(type_error("plain-old-data", v), v);
}
BUILTIN("sizeof", sizeof)
{
argcount(nargs, 1);
if(issym(args[0]) || iscons(args[0]))
return size_wrap(ctype_sizeof(args[0]));
usize n;
u8int *data;
uintptr u;
to_sized_ptr(args[0], &data, &n, &u);
return size_wrap(n);
}
sl_purefn
BUILTIN("typeof", typeof)
{
sl_v v = args[0];
argcount(nargs, 1);
switch(tag(v)){
case TAG_CONS: return sl_conssym;
case TAG_FIXNUM: return sl_fixnumsym;
case TAG_UNBOXED:
if(isubnum(v))
return unboxedtypesyms[ubnumtype(v)];
if(isrune(v))
return sl_runesym;
abort();
case TAG_SYM: return sl_symsym;
case TAG_VEC:return sl_vecsym;
case TAG_FN:
if(v == sl_t)
return sl_booleansym;
if(v == sl_nil)
return sl_nullsym;
if(v == sl_eof)
return sl_eof;
if(v == sl_void)
return sl_void;
if(isbuiltin(v))
return sl_builtinsym;
return sl_fnsym;
}
return cv_type(ptr(v));
}
sl_v
cvalue_relocate(sl_v v)
{
usize nw;
sl_cv *cv = ptr(v);
sl_cv *nv;
sl_v ncv;
nw = cv_nwords(cv);
nv = alloc_words(nw);
memcpy(nv, cv, nw*sizeof(sl_v));
if(isinlined(cv))
nv->data = nv->_space;
ncv = tagptr(nv, TAG_CVALUE);
sl_type *t = cv_class(cv);
if(t->vtable != nil && t->vtable->relocate != nil)
t->vtable->relocate(v, ncv);
forward(v, ncv);
if(slg.exiting && t->vtable != nil)
add_finalizer(ptr(ncv));
return ncv;
}
sl_v
cvalue_copy(sl_v v)
{
assert(iscvalue(v));
PUSH(v);
sl_cv *cv = ptr(v);
usize nw = cv_nwords(cv);
sl_cv *ncv = alloc_words(nw);
v = POP();
cv = ptr(v);
memcpy(ncv, cv, nw * sizeof(sl_v));
if(!isinlined(cv)){
usize len = cv_len(cv);
if(cv_isstr(cv))
len++;
ncv->data = MEM_ALLOC(len);
memcpy(ncv->data, cv_data(cv), len);
cv_autorelease(ncv);
}else{
ncv->data = ncv->_space;
}
return tagptr(ncv, TAG_CVALUE);
}
BUILTIN("copy", copy)
{
argcount(nargs, 1);
if(iscons(args[0]) || isvec(args[0]))
bthrow(lerrorf(sl_errarg, "argument must be a leaf atom"));
if(!iscvalue(args[0]))
return args[0];
if(!cv_isPOD(ptr(args[0])))
bthrow(lerrorf(sl_errarg, "argument must be a plain-old-data type"));
return cvalue_copy(args[0]);
}
sl_purefn
BUILTIN("plain-old-data?", plain_old_datap)
{
argcount(nargs, 1);
return (isubnum(args[0]) ||
isrune(args[0]) ||
(iscvalue(args[0]) && cv_isPOD(ptr(args[0]))))
? sl_t
: sl_nil;
}
static void
cvalue_init(sl_type *type, sl_v v, void *dest)
{
cvinitfunc_t f = type->init;
if(f == nil)
cthrow(lerrorf(sl_errarg, "invalid c type"), type);
f(type, v, dest);
}
// (c-value type . args)
// this provides (1) a way to allocate values with a shared type for
// efficiency, (2) a uniform interface for allocating cvalues of any
// type, including user-defined.
BUILTIN("c-value", c_value)
{
if(nargs < 1 || nargs > 2)
argcount(nargs, 2);
sl_v type = args[0];
sl_type *ft = get_type(type);
sl_v v;
if(ft->eltype != nil){
// special case to handle incomplete array types bla[]
usize elsz = ft->elsz;
usize cnt = 0;
if(iscons(cdr_(cdr_(type))))
cnt = tosize(car_(cdr_(cdr_(type))));
else if(nargs == 2)
cnt = predict_arrlen(args[1]);
v = cvalue(ft, elsz*cnt);
if(nargs == 2)
cvalue_arr_init(ft, args[1], cvalue_data(v));
else
memset(cvalue_data(v), 0, elsz*cnt);
}else{
v = cvalue(ft, ft->size);
if(nargs == 2)
cvalue_init(ft, args[1], cvalue_data(v));
else
memset(cvalue_data(v), 0, ft->size);
}
return v;
}
// NOTE: this only compares lexicographically; it ignores numeric formats
sl_v
cvalue_compare(sl_v a, sl_v b)
{
sl_cv *ca = ptr(a);
sl_cv *cb = ptr(b);
char *adata = cv_data(ca);
char *bdata = cv_data(cb);
usize asz = cv_len(ca);
usize bsz = cv_len(cb);
usize minsz = asz < bsz ? asz : bsz;
int diff = memcmp(adata, bdata, minsz);
if(diff == 0){
if(asz > bsz)
return fixnum(1);
if(asz < bsz)
return fixnum(-1);
}
return fixnum(diff);
}
static void
check_addr_args(sl_v arr, sl_v ind, u8int **data, int *index)
{
int numel;
sl_cv *cv = ptr(arr);
*data = cv_data(cv);
numel = cv_len(cv)/cv_class(cv)->elsz;
*index = tosize(ind);
if(*index < 0 || *index >= numel)
cthrow(bounds_error(arr, ind), arr);
}
sl_v
cvalue_arr_aref(sl_v *args)
{
u8int *data;
int index;
check_addr_args(args[0], args[1], &data, &index);
sl_type *eltype = cv_class(ptr(args[0]))->eltype;
sl_numtype nt = eltype->numtype;
if(nt < T_UNBOXED_NUM){
switch(nt){
case T_S8: return mk_s8(data[index]);
case T_U8: return mk_u8(data[index]);
case T_S16: return mk_s16(((s16int*)data)[index]);
case T_U16: return mk_u16(((u16int*)data)[index]);
case T_S32: return mk_s32(((s32int*)data)[index]);
case T_U32: return mk_u32(((u32int*)data)[index]);
case T_S64: return mk_s64(((s64int*)data)[index]);
case T_U64: return mk_u64(((u64int*)data)[index]);
case T_PTR: return mk_ptr(((uintptr*)data)[index]);
default: break;
}
}
if(eltype == sl_runetype)
return mk_rune(((Rune*)data)[index]);
sl_v el = cvalue(eltype, eltype->size);
u8int *dest = cvalue_data(el);
memcpy(dest, data + index*eltype->size, eltype->size);
return el;
}
sl_v
cvalue_arr_aset(sl_v *args)
{
u8int *data; int index;
sl_type *eltype = cv_class(ptr(args[0]))->eltype;
check_addr_args(args[0], args[1], &data, &index);
u8int *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];
}
sl_purefn
BUILTIN("builtin", builtin)
{
argcount(nargs, 1);
sl_sym *s = tosym(args[0]);
if(!iscbuiltin(s->binding))
bthrow(lerrorf(sl_errarg, "function \"%s\" not found", s->name));
return s->binding;
}
sl_v
cbuiltin(const char *name, builtin_t f)
{
sl_cv *cv;
cv = MEM_CALLOC(CVALUE_NWORDS-1, sizeof(*cv));
assert(cv != nil);
cv->type = sl_builtintype;
cv->cbuiltin = f;
sl_v sym = mk_sym(name, false);
sl_sym *s = ptr(sym);
s->binding = tagptr(cv, TAG_CVALUE);
ptrhash_put(&slg.reverse_dlsym_lookup, cv, (void*)sym);
return s->binding;
}
#define cv_intern(tok) \
do{ \
sl_##tok##sym = mk_csym(#tok); \
}while(0)
#define ctor_cv_intern(tok, nt, ctype) \
do{ \
sl_sym *s; \
cv_intern(tok); \
set(sl_##tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \
if(valid_numtype(nt)){ \
s = ptr(sl_##tok##sym); \
s->numtype = nt; \
s->size = sizeof(ctype); \
} \
}while(0)
#define mk_primtype(name, ctype) \
do{ \
sl_##name##type = get_type(sl_##name##sym); \
sl_##name##type->init = cvalue_##ctype##_init; \
}while(0)
#define RETURN_NUM_AS(var, type) return(mk_##type(var))
sl_constfn
sl_v
return_from_u64(u64int Uaccum)
{
if(fits_fixnum(Uaccum))
return fixnum((sl_fx)Uaccum);
if(Uaccum > (u64int)INT64_MAX)
RETURN_NUM_AS(Uaccum, u64);
if(Uaccum > (u64int)UINT32_MAX)
RETURN_NUM_AS(Uaccum, s64);
if(Uaccum > (u64int)INT32_MAX)
RETURN_NUM_AS(Uaccum, u32);
RETURN_NUM_AS(Uaccum, s32);
}
sl_v
return_from_s64(s64int Saccum)
{
if(fits_fixnum(Saccum))
return fixnum((sl_fx)Saccum);
RETURN_NUM_AS(vtomp(Saccum, nil), bignum);
}
#define ACCUM_DEFAULT 0
#define ARITH_OP(a, b) (a)+(b)
#define MP_OP mpadd
#define ARITH_OVERFLOW sadd_overflow_64
sl_v
sl_add_any(sl_v *args, u32int nargs)
{
#include "sl_arith_any.h"
}
#define ACCUM_DEFAULT 1
#define ARITH_OP(a, b) (a)*(b)
#define MP_OP mpmul
#define ARITH_OVERFLOW smul_overflow_64
sl_v
sl_mul_any(sl_v *args, u32int nargs)
{
#include "sl_arith_any.h"
}
sl_v
sl_neg(sl_v n)
{
s64int i64;
u64int ui64;
uintptr uiptr;
mpint *mp;
sl_numtype pt;
sl_fx pi;
void *a;
if(num_to_ptr(n, &pi, &pt, &a)){
switch(pt){
case T_DOUBLE: return mk_double(-*(double*)a);
case T_FLOAT: return mk_float(-*(float*)a);
case T_S8: return fixnum(-(sl_fx)*(s8int*)a);
case T_U8: return fixnum(-(sl_fx)*(u8int*)a);
case T_S16: return fixnum(-(sl_fx)*(s16int*)a);
case T_U16: return fixnum(-(sl_fx)*(u16int*)a);
case T_U32:
i64 = -(s64int)*(u32int*)a;
goto i64neg;
case T_S32:
i64 = -(s64int)*(s32int*)a;
goto i64neg;
case T_S64:
i64 = *(s64int*)a;
if(i64 == INT64_MIN)
return mk_bignum(uvtomp((u64int)INT64_MAX+1, nil));
i64 = -i64;
i64neg:
return fits_fixnum(i64) ? fixnum(i64) : mk_bignum(vtomp(i64, nil));
case T_U64:
ui64 = *(u64int*)a;
if(ui64 >= (u64int)INT64_MAX+1){
mp = uvtomp(ui64, nil);
mp->sign = -1;
return mk_bignum(mp);
}
i64 = -(s64int)ui64;
goto i64neg;
case T_PTR:
uiptr = *(uintptr*)a;
if(uiptr >= (u64int)INT64_MAX+1){
mp = uvtomp(uiptr, nil);
mp->sign = -1;
return mk_bignum(mp);
}
i64 = -(s64int)uiptr;
goto i64neg;
break;
case T_BIGNUM:
mp = mpcopy(*(mpint**)a);
mp->sign = -mp->sign;
return mk_bignum(mp);
}
}
cthrow(type_error("num", n), n);
}
bool
num_to_ptr(sl_v a, sl_fx *pi, sl_numtype *pt, void **pp)
{
sl_cv *cv;
if(isfixnum(a)){
*pi = numval(a);
*pp = pi;
*pt = T_FIXNUM;
return true;
}else if(isubnum(a)){
*pi = ubnumval(a);
*pp = pi;
*pt = ubnumtype(a);
return true;
}else if(iscvalue(a)){
cv = ptr(a);
*pp = cv_data(cv);
*pt = cv_numtype(cv);
return valid_numtype(*pt);
}
return false;
}
/*
returns -1, 0, or 1 based on ordering of a and b
eq: consider equality only, returning 0 or nonzero
eqnans: NaNs considered equal to each other
-0.0 not considered equal to 0.0
inexact not considered equal to exact
typeerr: if not 0, throws type errors, else returns 2 for type errors
*/
int
numeric_compare(sl_v a, sl_v b, bool eq, bool eqnans, bool typeerr)
{
sl_fx ai, bi;
sl_numtype ta, tb;
void *aptr, *bptr;
if(bothfixnums(a, b)){
if(!eq && numval(a) < numval(b))
return -1;
if(a == b)
return 0;
return 1;
}
if(!num_to_ptr(a, &ai, &ta, &aptr)){
if(typeerr)
cthrow(type_error("num", a), a);
return 2;
}
if(!num_to_ptr(b, &bi, &tb, &bptr)){
if(typeerr)
cthrow(type_error("num", b), a);
return 2;
}
if(eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
return 1;
if(cmp_eq(aptr, ta, bptr, tb, eqnans))
return 0;
if(eq)
return 1;
if(cmp_lt(aptr, ta, bptr, tb))
return -1;
return 1;
}
_Noreturn void
divide_by_0_error(void)
{
lerrorf(sl_errdiv0, "/: division by zero");
}
sl_v
sl_div2(sl_v a, sl_v b)
{
double da, db;
sl_fx ai, bi;
sl_numtype ta, tb;
void *aptr, *bptr;
if(!num_to_ptr(a, &ai, &ta, &aptr))
cthrow(type_error("num", a), a);
if(!num_to_ptr(b, &bi, &tb, &bptr))
cthrow(type_error("num", b), a);
// a pointer is not exactly a number
if(ta == T_PTR)
cthrow(type_error("num", a), a);
if(tb == T_PTR)
cthrow(type_error("num", b), a);
da = conv_to_double(a, aptr, ta);
db = conv_to_double(b, bptr, tb);
if(db == 0 && tb < T_FLOAT) // exact 0
cthrow(divide_by_0_error(), a);
da = da/db;
if(ta < T_FLOAT && tb < T_FLOAT && (double)(s64int)da == da)
return return_from_s64((s64int)da);
return mk_double(da);
}
sl_v
sl_idiv2(sl_v a, sl_v b)
{
sl_fx ai, bi;
sl_numtype ta, tb;
void *aptr, *bptr;
s64int a64, b64;
mpint *x;
if(!num_to_ptr(a, &ai, &ta, &aptr))
cthrow(type_error("num", a), a);
if(!num_to_ptr(b, &bi, &tb, &bptr))
cthrow(type_error("num", b), a);
// a pointer is not exactly a number
if(ta == T_PTR)
cthrow(type_error("num", a), a);
if(tb == T_PTR)
cthrow(type_error("num", b), a);
if(ta == T_BIGNUM){
if(tb == T_BIGNUM){
if(mpsignif(*(mpint**)bptr) == 0)
cthrow(divide_by_0_error(), a);
x = mpnew(0);
mpdiv(*(mpint**)aptr, *(mpint**)bptr, x, nil);
return mk_bignum(x);
}else{
b64 = conv_to_s64(b, bptr, tb);
if(b64 == 0)
cthrow(divide_by_0_error(), a);
x = tb == T_U64 ? uvtomp(b64, nil) : vtomp(b64, nil);
mpdiv(*(mpint**)aptr, x, x, nil);
return mk_bignum(x);
}
}
if(ta == T_U64){
if(tb == T_U64){
if(*(u64int*)bptr == 0)
cthrow(divide_by_0_error(), a);
return return_from_u64(*(u64int*)aptr / *(u64int*)bptr);
}
b64 = conv_to_s64(b, bptr, tb);
if(b64 < 0)
return return_from_s64(-(s64int)(*(u64int*)aptr / (u64int)(-b64)));
if(b64 == 0)
cthrow(divide_by_0_error(), a);
return return_from_u64(*(u64int*)aptr / (u64int)b64);
}
if(tb == T_U64){
if(*(u64int*)bptr == 0)
cthrow(divide_by_0_error(), a);
a64 = conv_to_s64(a, aptr, ta);
if(a64 < 0)
return return_from_s64(-((s64int)((u64int)(-a64) / *(u64int*)bptr)));
return return_from_u64((u64int)a64 / *(u64int*)bptr);
}
b64 = conv_to_s64(b, bptr, tb);
if(b64 == 0)
cthrow(divide_by_0_error(), a);
return return_from_s64(conv_to_s64(a, aptr, ta) / b64);
}
static sl_v
sl_bitwise_op(sl_v a, sl_v b, int opcode)
{
sl_fx ai, bi;
sl_numtype ta, tb, itmp;
void *aptr = nil, *bptr = nil, *ptmp;
mpint *bmp = nil, *resmp = nil;
s64int b64;
if(!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
cthrow(type_error("int", a), a);
if(!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
cthrow(type_error("int", b), a);
if(ta < tb){
itmp = ta; ta = tb; tb = itmp;
ptmp = aptr; aptr = bptr; bptr = ptmp;
}
// now a's type is larger than or same as b's
if(ta == T_BIGNUM){
if(tb == T_BIGNUM){
bmp = *(mpint**)bptr;
resmp = mpnew(0);
}else{
bmp = conv_to_bignum(b, bptr, tb);
resmp = bmp;
}
b64 = 0;
}else
b64 = conv_to_s64(b, bptr, tb);
switch(opcode){
case 0:
switch(ta){
case T_S8: return fixnum(*(s8int *)aptr & (s8int )b64);
case T_U8: return fixnum(*(u8int *)aptr & (u8int )b64);
case T_S16: return fixnum(*(s16int*)aptr & (s16int)b64);
case T_U16: return fixnum(*(u16int*)aptr & (u16int)b64);
case T_S32: return mk_s32(*(s32int*)aptr & (s32int)b64);
case T_U32: return mk_u32(*(u32int*)aptr & (u32int)b64);
case T_S64: return mk_s64(*(s64int*)aptr & (s64int)b64);
case T_U64: return mk_u64(*(u64int*)aptr & (u64int)b64);
case T_PTR: return mk_ptr(*(uintptr*)aptr & (uintptr)b64);
case T_BIGNUM: mpand(*(mpint**)aptr, bmp, resmp); return mk_bignum(resmp);
case T_FLOAT:
case T_DOUBLE: break;
}
break;
case 1:
switch(ta){
case T_S8: return fixnum(*(s8int *)aptr | (s8int )b64);
case T_U8: return fixnum(*(u8int *)aptr | (u8int )b64);
case T_S16: return fixnum(*(s16int*)aptr | (s16int)b64);
case T_U16: return fixnum(*(u16int*)aptr | (u16int)b64);
case T_S32: return mk_s32(*(s32int*)aptr | (s32int)b64);
case T_U32: return mk_u32(*(u32int*)aptr | (u32int)b64);
case T_S64: return mk_s64(*(s64int*)aptr | (s64int)b64);
case T_U64: return mk_u64(*(u64int*)aptr | (u64int)b64);
case T_PTR: return mk_ptr(*(uintptr*)aptr | (uintptr)b64);
case T_BIGNUM: mpor(*(mpint**)aptr, bmp, resmp); return mk_bignum(resmp);
case T_FLOAT:
case T_DOUBLE: break;
}
break;
case 2:
switch(ta){
case T_S8: return fixnum(*(s8int *)aptr ^ (s8int )b64);
case T_U8: return fixnum(*(u8int *)aptr ^ (u8int )b64);
case T_S16: return fixnum(*(s16int*)aptr ^ (s16int)b64);
case T_U16: return fixnum(*(u16int*)aptr ^ (u16int)b64);
case T_S32: return mk_s32(*(s32int*)aptr ^ (s32int)b64);
case T_U32: return mk_u32(*(u32int*)aptr ^ (u32int)b64);
case T_S64: return mk_s64(*(s64int*)aptr ^ (s64int)b64);
case T_U64: return mk_u64(*(u64int*)aptr ^ (u64int)b64);
case T_PTR: return mk_ptr(*(uintptr*)aptr ^ (uintptr)b64);
case T_BIGNUM: mpxor(*(mpint**)aptr, bmp, resmp); return mk_bignum(resmp);
case T_FLOAT:
case T_DOUBLE: break;
}
}
abort();
}
BUILTIN("logand", logand)
{
sl_v v, e;
if(nargs == 0)
return fixnum(-1);
v = args[0];
int i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = v & e;
else
v = sl_bitwise_op(v, e, 0);
}
return v;
}
BUILTIN("logior", logior)
{
sl_v v, e;
if(nargs == 0)
return fixnum(0);
v = args[0];
int i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = v | e;
else
v = sl_bitwise_op(v, e, 1);
}
return v;
}
BUILTIN("logxor", logxor)
{
sl_v v, e;
if(nargs == 0)
return fixnum(0);
v = args[0];
int i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = sl_bitwise_op(v, e, 2);
}
return v;
}
BUILTIN("lognot", lognot)
{
argcount(nargs, 1);
sl_v a = args[0];
void *aptr;
if(isfixnum(a))
return fixnum(~numval(a));
if(isubnum(a))
return (~ubnumval(a) & ~0xff) | (a & 0xff);
if(iscvalue(a)){
sl_cv *cv = ptr(a);
sl_numtype ta = cv_numtype(cv);
aptr = cv_data(cv);
switch(ta){
case T_S32: return mk_s32(~*(s32int*)aptr);
case T_U32: return mk_u32(~*(u32int*)aptr);
case T_S64: return mk_s64(~*(s64int*)aptr);
case T_U64: return mk_u64(~*(u64int*)aptr);
case T_PTR: return mk_ptr(~*(uintptr*)aptr);
case T_BIGNUM:; mpint *m = mpnew(0); mpnot(*(mpint**)aptr, m); return mk_bignum(m);
default: abort();
}
}
bthrow(type_error("int", a));
}
#define sash_overflow_64(a, b, c) ( \
((a)<0 || (a)>(INT64_MAX>>(b))) \
? 1 \
: ((*(c)=(a)<<(b)), 0) \
)
BUILTIN("ash", ash)
{
sl_fx n;
s64int accum;
mpint *mp;
void *aptr;
argcount(nargs, 2);
sl_v a = args[0];
n = tofixnum(args[1]);
if(n == 0)
return a;
mp = nil;
if(isfixnum(a) || isubnum(a)){
accum = isfixnum(a) ? numval(a) : ubnumval(a);
if(n > -64 && n < 0)
return fixnum(accum>>(-n));
if(n < 0 || n >= 64 || sash_overflow_64(accum, n, &accum)){
mp = vtomp(accum, nil);
mpleft(mp, n, mp);
}else
return fits_fixnum(accum) ? fixnum(accum) : return_from_s64(accum);
}
if(isbignum(a)){
aptr = cv_data(ptr(a));
mp = mpnew(0);
mpleft(*(mpint**)aptr, n, mp);
}else if(iscvalue(a)){
sl_cv *cv = ptr(a);
sl_numtype ta = cv_numtype(cv);
aptr = cv_data(cv);
if(n < 0){
n = -n;
switch(ta){
case T_S32: return mk_s32((*(s32int*)aptr) >> n);
case T_U32: return mk_u32((*(u32int*)aptr) >> n);
case T_S64: return mk_s64((*(s64int*)aptr) >> n);
case T_U64: return mk_u64((*(u64int*)aptr) >> n);
case T_PTR: return mk_ptr((*(uintptr*)aptr) >> n);
default: abort();
}
}else if(ta == T_U64)
return return_from_u64((*(u64int*)aptr)<<n);
else if(ta == T_PTR)
return return_from_u64((*(uintptr*)aptr)<<n);
else if(ta < T_FLOAT)
return return_from_s64(conv_to_s64(a, aptr, ta)<<n);
}
if(mp != nil){
n = mpsignif(mp);
if(n >= FIXNUM_BITS)
return mk_bignum(mp);
accum = mptov(mp);
mpfree(mp);
assert(fits_fixnum(accum));
return fixnum((sl_fx)accum);
}
bthrow(type_error("int", a));
}
void
cvalues_init(void)
{
htable_new(&slg.types, 256);
htable_new(&slg.reverse_dlsym_lookup, 256);
ctor_cv_intern(rune, NONNUMERIC, u32int);
sl_sym *sym = ptr(sl_runesym);
sym->numtype = NONNUMERIC;
sym->size = sizeof(Rune);
sl_runetype = get_type(sl_runesym);
sl_runetype->init = cvalue_rune_init;
sl_builtintype = define_opaque_type(sl_builtinsym, sizeof(builtin_t), nil, nil);
ctor_cv_intern(s8, T_S8, s8int);
ctor_cv_intern(u8, T_U8, u8int);
ctor_cv_intern(s16, T_S16, s16int);
ctor_cv_intern(u16, T_U16, u16int);
ctor_cv_intern(s32, T_S32, s32int);
ctor_cv_intern(u32, T_U32, u32int);
ctor_cv_intern(s64, T_S64, s64int);
ctor_cv_intern(u64, T_U64, u64int);
ctor_cv_intern(ptr, T_PTR, uintptr);
ctor_cv_intern(float, T_FLOAT, float);
ctor_cv_intern(double, T_DOUBLE, double);
ctor_cv_intern(utf8, T_U8, u8int);
ctor_cv_intern(arr, NONNUMERIC, int);
mk_primtype(s8, s8int);
mk_primtype(u8, u8int);
mk_primtype(s16, s16int);
mk_primtype(u16, u16int);
mk_primtype(s32, s32int);
mk_primtype(u32, u32int);
mk_primtype(s64, s64int);
mk_primtype(u64, u64int);
mk_primtype(ptr, uintptr);
mk_primtype(float, float);
mk_primtype(double, double);
mk_primtype(utf8, u8int);
ctor_cv_intern(bignum, T_BIGNUM, mpint*);
sl_bignumtype = get_type(sl_bignumsym);
sl_bignumtype->init = cvalue_bignum_init;
sl_bignumtype->vtable = &bignum_vtable;
unboxedtypes[T_S8] = sl_s8type;
unboxedtypes[T_U8] = sl_u8type;
unboxedtypes[T_S16] = sl_s16type;
unboxedtypes[T_U16] = sl_u16type;
unboxedtypes[T_S32] = sl_s32type;
unboxedtypes[T_U32] = sl_u32type;
unboxedtypes[T_S64] = sl_s64type;
unboxedtypes[T_U64] = sl_u64type;
unboxedtypes[T_PTR] = sl_ptrtype;
unboxedtypesyms[T_S8] = sl_s8sym;
unboxedtypesyms[T_U8] = sl_u8sym;
unboxedtypesyms[T_S16] = sl_s16sym;
unboxedtypesyms[T_U16] = sl_u16sym;
unboxedtypesyms[T_S32] = sl_s32sym;
unboxedtypesyms[T_U32] = sl_u32sym;
unboxedtypesyms[T_S64] = sl_s64sym;
unboxedtypesyms[T_U64] = sl_u64sym;
unboxedtypesyms[T_PTR] = sl_ptrsym;
sl_strtype = get_type(mk_list2(sl_arrsym, sl_utf8sym));
sl_emptystr = cvalue_from_ref(sl_strtype, (char*)"", 0);
}