ref: 0864e3a7e23a6e3f6db9049abd3c70fd7e181606
dir: /cvalues.c/
#include "flisp.h"
#include "operators.h"
#include "cvalues.h"
#include "types.h"
#include "iostream.h"
#include "equal.h"
// trigger unconditional GC after this many bytes are allocated
#define ALLOC_LIMIT_TRIGGER 67108864
static void cvalue_init(fltype_t *type, value_t v, void *dest);
void
add_finalizer(cvalue_t *cv)
{
if(FL(nfinalizers) == FL(maxfinalizers)){
size_t nn = FL(maxfinalizers) == 0 ? 256 : FL(maxfinalizers)*2;
cvalue_t **temp = MEM_REALLOC(FL(finalizers), nn*sizeof(cvalue_t*));
if(temp == nil)
lerrorf(FL(MemoryError), "out of memory");
FL(finalizers) = temp;
FL(maxfinalizers) = nn;
}
FL(finalizers)[FL(nfinalizers)++] = cv;
}
// remove dead objects from finalization list in-place
void
sweep_finalizers(void)
{
cvalue_t **lst = FL(finalizers);
size_t n = 0, ndel = 0, l = FL(nfinalizers);
cvalue_t *tmp;
#define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1)
if(l == 0)
return;
do{
tmp = lst[n];
if(isforwarded((value_t)tmp)){
// object is alive
lst[n] = ptr(forwardloc((value_t)tmp));
n++;
}else{
fltype_t *t = cv_class(tmp);
if(t->vtable != nil && t->vtable->finalize != nil)
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
if(!isinlined(tmp) && owned(tmp) && !FL(exiting)){
memset(cv_data(tmp), 0xbb, cv_len(tmp));
MEM_FREE(cv_data(tmp));
}
ndel++;
}
}while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel]));
FL(nfinalizers) -= ndel;
#if defined(VERBOSEGC)
if(ndel > 0)
printf("GC: finalized %d objects\n", ndel);
#endif
FL(malloc_pressure) = 0;
}
// compute the size of the metadata object for a cvalue
static size_t
cv_nwords(cvalue_t *cv)
{
if(isinlined(cv)){
size_t n = cv_len(cv);
if(n == 0 || cv_isstr(cv))
n++;
return CVALUE_NWORDS - 1 + NWORDS(n);
}
return CVALUE_NWORDS;
}
static void
autorelease(cvalue_t *cv)
{
cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED_BIT);
add_finalizer(cv);
}
void
cv_autorelease(cvalue_t *cv)
{
autorelease(cv);
}
static value_t
cprim(fltype_t *type, size_t sz)
{
assert(!ismanaged((uintptr_t)type));
assert(sz == type->size);
cprim_t *pcp = alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
pcp->type = type;
return tagptr(pcp, TAG_CPRIM);
}
value_t
cvalue_(fltype_t *type, size_t sz, bool nofinalize)
{
cvalue_t *pcv;
int str = 0;
assert(type != nil);
if(valid_numtype(type->numtype) && type->numtype != T_MPINT)
return cprim(type, sz);
if(type->eltype == FL(bytetype)){
if(sz == 0)
return symbol_value(FL(emptystringsym));
sz++;
str = 1;
}
if(sz <= MAX_INL_SIZE){
size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz == 0 ? 1 : 0);
pcv = alloc_words(nw);
pcv->type = type;
pcv->data = &pcv->_space[0];
if(!nofinalize && type->vtable != nil && type->vtable->finalize != nil)
add_finalizer(pcv);
}else{
if(FL(malloc_pressure) > ALLOC_LIMIT_TRIGGER)
gc(0);
pcv = alloc_words(CVALUE_NWORDS);
pcv->type = type;
pcv->data = MEM_ALLOC(sz);
autorelease(pcv);
FL(malloc_pressure) += sz;
}
if(str)
((char*)pcv->data)[--sz] = '\0';
pcv->len = sz;
return tagptr(pcv, TAG_CVALUE);
}
value_t
cvalue_from_data(fltype_t *type, void *data, size_t sz)
{
value_t cv;
cv = cvalue(type, sz);
memcpy(cptr(cv), data, sz);
return cv;
}
// 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.
value_t
cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent)
{
cvalue_t *pcv;
value_t cv;
assert(type != nil);
assert(ptr != nil);
pcv = alloc_words(CVALUE_NWORDS);
pcv->data = ptr;
pcv->len = sz;
pcv->type = type;
if(parent != FL(Nil)){
pcv->type = (fltype_t*)(((uintptr_t)pcv->type) | CV_PARENT_BIT);
pcv->parent = parent;
}
cv = tagptr(pcv, TAG_CVALUE);
return cv;
}
value_t
cvalue_string(size_t sz)
{
return cvalue(FL(stringtype), sz);
}
value_t
cvalue_static_cstring(const char *str)
{
return cvalue_from_ref(FL(stringtype), (char*)str, strlen(str), FL(Nil));
}
value_t
string_from_cstrn(char *str, size_t n)
{
value_t v = cvalue_string(n);
memcpy(cvalue_data(v), str, n);
return v;
}
value_t
string_from_cstr(char *str)
{
return string_from_cstrn(str, strlen(str));
}
int
fl_isstring(value_t v)
{
return iscvalue(v) && cv_isstr((cvalue_t*)ptr(v));
}
// convert to malloc representation (fixed address)
void
cv_pin(cvalue_t *cv)
{
if(!isinlined(cv))
return;
size_t sz = cv_len(cv);
if(cv_isstr(cv))
sz++;
void *data = MEM_ALLOC(sz);
memcpy(data, cv_data(cv), sz);
cv->data = data;
autorelease(cv);
}
#define num_init(ctype, cnvt, tag) \
static int \
cvalue_##ctype##_init(fltype_t *type, value_t arg, void *dest) \
{ \
ctype n; \
USED(type); \
if(isfixnum(arg)) \
n = (ctype)numval(arg); \
else if(iscprim(arg)){ \
cprim_t *cp = ptr(arg); \
void *p = cp_data(cp); \
n = (ctype)conv_to_##cnvt(p, cp_numtype(cp)); \
}else if(iscvalue(arg) && cp_numtype(ptr(arg)) == T_MPINT){ \
cvalue_t *cv = ptr(arg); \
void *p = cv_data(cv); \
n = (ctype)conv_to_##cnvt(p, T_MPINT); \
}else \
return 1; \
*((ctype*)dest) = n; \
return 0; \
}
num_init(int8_t, int32, T_INT8)
num_init(uint8_t, uint32, T_UINT8)
num_init(int16_t, int32, T_INT16)
num_init(uint16_t, uint32, T_UINT16)
num_init(int32_t, int32, T_INT32)
num_init(uint32_t, uint32, T_UINT32)
num_init(int64_t, int64, T_INT64)
num_init(uint64_t, uint64, T_UINT64)
num_init(float, double, T_FLOAT)
num_init(double, double, T_DOUBLE)
#define num_ctor_init(typenam, ctype, tag) \
static \
BUILTIN(#typenam, typenam) \
{ \
if(nargs == 0){ \
PUSH(fixnum(0)); \
args = &FL(stack)[FL(sp)-1]; \
} \
value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
if(cvalue_##ctype##_init(FL(typenam##type), args[0], cp_data((cprim_t*)ptr(cp)))) \
type_error("number", args[0]); \
return cp; \
}
#define num_ctor_ctor(typenam, ctype, tag) \
value_t mk_##typenam(ctype n) \
{ \
value_t cp = cprim(FL(typenam##type), sizeof(ctype)); \
*(ctype*)cp_data((cprim_t*)ptr(cp)) = n; \
return cp; \
}
#define num_ctor(typenam, ctype, tag) \
num_ctor_init(typenam, ctype, tag) \
num_ctor_ctor(typenam, ctype, tag)
num_ctor_init(int8, int8_t, T_INT8)
num_ctor_init(uint8, uint8_t, T_UINT8)
num_ctor_init(int16, int16_t, T_INT16)
num_ctor_init(uint16, uint16_t, T_UINT16)
num_ctor(int32, int32_t, T_INT32)
num_ctor(uint32, uint32_t, T_UINT32)
num_ctor(int64, int64_t, T_INT64)
num_ctor(uint64, uint64_t, T_UINT64)
num_ctor_init(byte, uint8_t, T_UINT8)
num_ctor(float, float, T_FLOAT)
num_ctor(double, double, T_DOUBLE)
num_ctor(rune, uint32_t, T_UINT32)
static int
cvalue_mpint_init(fltype_t *type, value_t arg, void *dest)
{
mpint *n;
USED(type);
if(isfixnum(arg)){
n = vtomp(numval(arg), nil);
}else if(iscvalue(arg)){
cvalue_t *cv = ptr(arg);
void *p = cv_data(cv);
n = conv_to_mpint(p, cp_numtype(cv));
}else if(iscprim(arg)){
cprim_t *cp = (cprim_t*)ptr(arg);
void *p = cp_data(cp);
n = conv_to_mpint(p, cp_numtype(cp));
}else{
return 1;
}
*((mpint**)dest) = n;
return 0;
}
BUILTIN("bignum", bignum)
{
if(nargs == 0){
PUSH(fixnum(0));
args = &FL(stack)[FL(sp)-1];
}
value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
if(cvalue_mpint_init(FL(mpinttype), args[0], cvalue_data(cv)))
type_error("number", args[0]);
return cv;
}
value_t
mk_mpint(mpint *n)
{
value_t cv = cvalue(FL(mpinttype), sizeof(mpint*));
*(mpint**)cvalue_data(cv) = n;
return cv;
}
static void
free_mpint(value_t self)
{
mpint **s = value2c(mpint**, self);
if(*s != mpzero && *s != mpone && *s != mptwo)
mpfree(*s);
}
static cvtable_t mpint_vtable = { nil, nil, free_mpint, nil };
value_t
size_wrap(size_t sz)
{
if(sizeof(size_t) == 8)
return fits_fixnum(sz) ? fixnum(sz): mk_uint64(sz);
else
return fits_fixnum(sz) ? fixnum(sz): mk_uint32(sz);
}
size_t
tosize(value_t n)
{
if(isfixnum(n))
return (size_t)numval(n);
if(iscprim(n)){
cprim_t *cp = (cprim_t*)ptr(n);
if(sizeof(size_t) == 8)
return conv_to_uint64(cp_data(cp), cp_numtype(cp));
return conv_to_uint32(cp_data(cp), cp_numtype(cp));
}
type_error("number", n);
}
off_t
tooffset(value_t n)
{
if(isfixnum(n))
return numval(n);
if(iscprim(n)){
cprim_t *cp = (cprim_t*)ptr(n);
return conv_to_int64(cp_data(cp), cp_numtype(cp));
}
type_error("number", n);
}
int
cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
{
int n;
value_t syms;
value_t type = ft->type;
syms = car(cdr(type));
if(!isvector(syms))
type_error("vector", syms);
if(issymbol(arg)){
for(n = 0; n < (int)vector_size(syms); n++){
if(vector_elt(syms, n) == arg){
*(int*)dest = n;
return 0;
}
}
lerrorf(FL(ArgError), "invalid enum value");
}
if(isfixnum(arg))
n = (int)numval(arg);
else if(iscprim(arg)){
cprim_t *cp = (cprim_t*)ptr(arg);
n = conv_to_int32(cp_data(cp), cp_numtype(cp));
}else
type_error("number", arg);
if((unsigned)n >= vector_size(syms))
lerrorf(FL(ArgError), "value out of range");
*(int*)dest = n;
return 0;
}
BUILTIN("enum", enum)
{
argcount(nargs, 2);
value_t type = fl_list2(FL(enumsym), args[0]);
fltype_t *ft = get_type(type);
value_t cv = cvalue(ft, sizeof(int32_t));
cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv)));
return cv;
}
int
isarray(value_t v)
{
return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != nil;
}
static size_t
predict_arraylen(value_t arg)
{
if(isvector(arg))
return vector_size(arg);
if(iscons(arg))
return llength(arg);
if(arg == FL(Nil))
return 0;
if(isarray(arg))
return cvalue_arraylen(arg);
return 1;
}
int
cvalue_array_init(fltype_t *ft, value_t arg, void *dest)
{
value_t type = ft->type;
size_t elsize, i, cnt, sz;
fltype_t *eltype = ft->eltype;
elsize = ft->elsz;
cnt = predict_arraylen(arg);
if(iscons(cdr_(cdr_(type)))){
size_t tc = tosize(car_(cdr_(cdr_(type))));
if(tc != cnt)
lerrorf(FL(ArgError), "size mismatch");
}
sz = elsize * cnt;
if(isvector(arg)){
assert(cnt <= vector_size(arg));
for(i = 0; i < cnt; i++){
cvalue_init(eltype, vector_elt(arg, i), dest);
dest = (char*)dest + elsize;
}
return 0;
}
if(iscons(arg) || arg == FL(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)
lerrorf(FL(ArgError), "size mismatch");
return 0;
}
if(iscvalue(arg)){
cvalue_t *cv = (cvalue_t*)ptr(arg);
if(isarray(arg)){
fltype_t *aet = cv_class(cv)->eltype;
if(aet == eltype){
if(cv_len(cv) == sz)
memcpy(dest, cv_data(cv), sz);
else
lerrorf(FL(ArgError), "size mismatch");
return 0;
}else{
// TODO: initialize array from different type elements
lerrorf(FL(ArgError), "element type mismatch");
}
}
}
if(cnt == 1)
cvalue_init(eltype, arg, dest);
type_error("sequence", arg);
}
BUILTIN("array", array)
{
size_t elsize, cnt, sz;
value_t arg;
if(nargs < 1)
argcount(nargs, 1);
cnt = nargs - 1;
fltype_t *type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
value_t cv = cvalue(type, sz);
char *dest = cvalue_data(cv);
uint32_t i;
FOR_ARGS(i, 1, arg, args){
cvalue_init(type->eltype, arg, dest);
dest += elsize;
}
return cv;
}
BUILTIN("array-alloc", array_alloc)
{
size_t elsize, sz;
long i, cnt, a;
if(nargs < 3)
argcount(nargs, 3);
cnt = tosize(args[1]);
if(cnt < 0)
lerrorf(FL(ArgError), "invalid size: %d", cnt);
fltype_t *type = get_array_type(args[0]);
elsize = type->elsz;
sz = elsize * cnt;
value_t cv = cvalue(type, sz);
char *dest = cvalue_data(cv);
a = 2;
for(i = 0; i < cnt; i++){
cvalue_init(type->eltype, args[a], dest);
dest += elsize;
if((a = (a + 1) % nargs) < 2)
a = 2;
}
return cv;
}
// NOTE: v must be an array
size_t
cvalue_arraylen(value_t v)
{
cvalue_t *cv = ptr(v);
return cv_len(cv)/cv_class(cv)->elsz;
}
static size_t
cvalue_struct_offs(value_t type, value_t field, int computeTotal, int *palign)
{
value_t fld = car(cdr_(type));
size_t fsz, ssz = 0;
int al;
*palign = 0;
while(iscons(fld)){
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
ssz = ALIGNED(ssz, al);
if(al > *palign)
*palign = al;
if(!computeTotal && field == car_(car_(fld))) // found target field
return ssz;
ssz += fsz;
fld = cdr_(fld);
}
return ALIGNED(ssz, *palign);
}
static size_t
cvalue_union_size(value_t type, int *palign)
{
value_t fld = car(cdr_(type));
size_t fsz, usz = 0;
int al;
*palign = 0;
while(iscons(fld)){
fsz = ctype_sizeof(car(cdr(car_(fld))), &al);
if(al > *palign)
*palign = al;
if(fsz > usz)
usz = fsz;
fld = cdr_(fld);
}
return ALIGNED(usz, *palign);
}
// *palign is an output argument giving the alignment required by type
size_t
ctype_sizeof(value_t type, int *palign)
{
symbol_t *s;
if(issymbol(type) && (s = ptr(type)) != nil && valid_numtype(s->numtype)){
*palign = s->align;
return s->size;
}
if(iscons(type)){
value_t hed = car_(type);
if(hed == FL(structsym))
return cvalue_struct_offs(type, FL(Nil), 1, palign);
if(hed == FL(unionsym))
return cvalue_union_size(type, palign);
if(hed == FL(pointersym) || hed == FL(cfunctionsym)){
*palign = offsetof(struct{ char a; void *i; }, i);
return sizeof(void*);
}
if(hed == FL(arraysym)){
value_t t = car(cdr_(type));
if(!iscons(cdr_(cdr_(type))))
lerrorf(FL(ArgError), "incomplete type");
value_t n = car_(cdr_(cdr_(type)));
size_t sz = tosize(n);
return sz * ctype_sizeof(t, palign);
}
if(hed == FL(enumsym)){
*palign = offsetof(struct{ char c; numerictype_t e; }, e);
return sizeof(numerictype_t);
}
}
lerrorf(FL(ArgError), "invalid c type");
}
// get pointer and size for any plain-old-data value
void
to_sized_ptr(value_t v, uint8_t **pdata, size_t *psz)
{
if(iscvalue(v)){
cvalue_t *pcv = ptr(v);
ios_t *x = value2c(ios_t*, v);
if(cv_class(pcv) == FL(iostreamtype) && x->bm == bm_mem){
*pdata = x->buf;
*psz = x->size;
return;
}
if(cv_isPOD(pcv)){
*pdata = cv_data(pcv);
*psz = cv_len(pcv);
return;
}
}
if(iscprim(v)){
cprim_t *pcp = (cprim_t*)ptr(v);
*pdata = cp_data(pcp);
*psz = cp_class(pcp)->size;
return;
}
type_error("plain-old-data", v);
}
BUILTIN("sizeof", sizeof)
{
argcount(nargs, 1);
int a;
if(issymbol(args[0]) || iscons(args[0]))
return size_wrap(ctype_sizeof(args[0], &a));
size_t n;
uint8_t *data;
to_sized_ptr(args[0], &data, &n);
return size_wrap(n);
}
BUILTIN("typeof", typeof)
{
argcount(nargs, 1);
switch(tag(args[0])){
case TAG_CONS: return FL(pairsym);
case TAG_NUM1: case TAG_NUM: return FL(fixnumsym);
case TAG_SYM: return FL(symbolsym);
case TAG_VECTOR: return FL(vectorsym);
case TAG_FUNCTION:
if(args[0] == FL(t) || args[0] == FL(f))
return FL(booleansym);
if(args[0] == FL(Nil))
return FL(nullsym);
if(args[0] == FL(eof))
return FL(eof);
if(isbuiltin(args[0]))
return FL(builtinsym);
return FL(function);
}
return cv_type(ptr(args[0]));
}
value_t
cvalue_relocate(value_t v)
{
size_t nw;
cvalue_t *cv = ptr(v);
cvalue_t *nv;
value_t ncv;
nw = cv_nwords(cv);
nv = alloc_words(nw);
memcpy(nv, cv, nw*sizeof(value_t));
if(isinlined(cv))
nv->data = &nv->_space[0];
ncv = tagptr(nv, TAG_CVALUE);
fltype_t *t = cv_class(cv);
if(t->vtable != nil && t->vtable->relocate != nil)
t->vtable->relocate(v, ncv);
forward(v, ncv);
if(FL(exiting))
cv_autorelease(ptr(ncv));
return ncv;
}
value_t
cvalue_copy(value_t v)
{
assert(iscvalue(v));
PUSH(v);
cvalue_t *cv = ptr(v);
size_t nw = cv_nwords(cv);
cvalue_t *ncv = alloc_words(nw);
v = POP();
cv = ptr(v);
memcpy(ncv, cv, nw * sizeof(value_t));
if(!isinlined(cv)){
size_t len = cv_len(cv);
if(cv_isstr(cv))
len++;
ncv->data = MEM_ALLOC(len);
memcpy(ncv->data, cv_data(cv), len);
autorelease(ncv);
if(hasparent(cv)){
ncv->type = (fltype_t*)(((uintptr_t)ncv->type) & ~CV_PARENT_BIT);
ncv->parent = FL(Nil);
}
}else{
ncv->data = &ncv->_space[0];
}
return tagptr(ncv, TAG_CVALUE);
}
BUILTIN("copy", copy)
{
argcount(nargs, 1);
if(iscons(args[0]) || isvector(args[0]))
lerrorf(FL(ArgError), "argument must be a leaf atom");
if(!iscvalue(args[0]))
return args[0];
if(!cv_isPOD(ptr(args[0])))
lerrorf(FL(ArgError), "argument must be a plain-old-data type");
return cvalue_copy(args[0]);
}
BUILTIN("plain-old-data?", plain_old_datap)
{
argcount(nargs, 1);
return (iscprim(args[0]) ||
(iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
FL(t) : FL(f);
}
static void
cvalue_init(fltype_t *type, value_t v, void *dest)
{
cvinitfunc_t f = type->init;
if(f == nil)
lerrorf(FL(ArgError), "invalid c type");
f(type, v, dest);
}
// (new 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);
value_t type = args[0];
fltype_t *ft = get_type(type);
value_t cv;
if(ft->eltype != nil){
// special case to handle incomplete array types bla[]
size_t elsz = ft->elsz;
size_t cnt;
if(iscons(cdr_(cdr_(type))))
cnt = tosize(car_(cdr_(cdr_(type))));
else if(nargs == 2)
cnt = predict_arraylen(args[1]);
else
cnt = 0;
cv = cvalue(ft, elsz * cnt);
if(nargs == 2)
cvalue_array_init(ft, args[1], cvalue_data(cv));
}else{
cv = cvalue(ft, ft->size);
if(nargs == 2)
cvalue_init(ft, args[1], cptr(cv));
}
return cv;
}
// NOTE: this only compares lexicographically; it ignores numeric formats
value_t
cvalue_compare(value_t a, value_t b)
{
cvalue_t *ca = ptr(a);
cvalue_t *cb = ptr(b);
char *adata = cv_data(ca);
char *bdata = cv_data(cb);
size_t asz = cv_len(ca);
size_t bsz = cv_len(cb);
size_t 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(value_t arr, value_t ind, char **data, int *index)
{
int numel;
cvalue_t *cv = ptr(arr);
*data = cv_data(cv);
numel = cv_len(cv)/cv_class(cv)->elsz;
*index = tosize(ind);
if(*index < 0 || *index >= numel)
bounds_error(arr, ind);
}
value_t
cvalue_array_aref(value_t *args)
{
char *data; int index;
fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
value_t el = 0;
numerictype_t nt = eltype->numtype;
if(nt >= T_INT32)
el = cvalue(eltype, eltype->size);
check_addr_args(args[0], args[1], &data, &index);
if(nt < T_INT32){
if(nt == T_INT8)
return fixnum((int8_t)data[index]);
if(nt == T_UINT8)
return fixnum((uint8_t)data[index]);
if(nt == T_INT16)
return fixnum(((int16_t*)data)[index]);
return fixnum(((uint16_t*)data)[index]);
}
char *dest = cptr(el);
size_t sz = eltype->size;
if(sz == 1)
*dest = data[index];
else if(sz == 2)
*(int16_t*)dest = ((int16_t*)data)[index];
else if(sz == 4)
*(int32_t*)dest = ((int32_t*)data)[index];
else if(sz == 8)
*(int64_t*)dest = ((int64_t*)data)[index];
else
memcpy(dest, data + index*sz, sz);
return el;
}
value_t
cvalue_array_aset(value_t *args)
{
char *data; int index;
fltype_t *eltype = cv_class(ptr(args[0]))->eltype;
check_addr_args(args[0], args[1], &data, &index);
char *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];
}
BUILTIN("builtin", builtin)
{
argcount(nargs, 1);
symbol_t *name = tosymbol(args[0]);
cvalue_t *cv;
if(ismanaged(args[0]) || (cv = name->dlcache) == nil)
lerrorf(FL(ArgError), "function %s not found", name->name);
return tagptr(cv, TAG_CVALUE);
}
value_t
cbuiltin(char *name, builtin_t f)
{
cvalue_t *cv;
cv = calloc(CVALUE_NWORDS, sizeof(*cv));
cv->type = FL(builtintype);
cv->data = &cv->_space[0];
cv->len = sizeof(value_t);
*(builtin_t*)cv->data = f;
value_t sym = symbol(name, false);
((symbol_t*)ptr(sym))->dlcache = cv;
ptrhash_put(&FL(reverse_dlsym_lookup_table), cv, (void*)sym);
return tagptr(cv, TAG_CVALUE);
}
#define cv_intern(tok) \
do{ \
FL(tok##sym) = symbol(#tok, false); \
}while(0)
#define ctor_cv_intern(tok, nt, ctype) \
do{ \
symbol_t *s; \
cv_intern(tok); \
set(FL(tok##sym), cbuiltin(#tok, fn_builtin_##tok)); \
if(valid_numtype(nt)){ \
s = ptr(FL(tok##sym)); \
s->numtype = nt; \
s->size = sizeof(ctype); \
s->align = offsetof(struct{char c; ctype x;}, x); \
} \
}while(0)
#define mk_primtype(name, ctype) \
do{ \
FL(name##type) = get_type(FL(name##sym)); \
FL(name##type)->init = cvalue_##ctype##_init; \
}while(0)
#define RETURN_NUM_AS(var, type) return(mk_##type(var))
value_t
return_from_uint64(uint64_t Uaccum)
{
if(fits_fixnum(Uaccum))
return fixnum((fixnum_t)Uaccum);
if(Uaccum > (uint64_t)INT64_MAX)
RETURN_NUM_AS(Uaccum, uint64);
if(Uaccum > (uint64_t)UINT32_MAX)
RETURN_NUM_AS(Uaccum, int64);
if(Uaccum > (uint64_t)INT32_MAX)
RETURN_NUM_AS(Uaccum, uint32);
RETURN_NUM_AS(Uaccum, int32);
}
value_t
return_from_int64(int64_t Saccum)
{
if(fits_fixnum(Saccum))
return fixnum((fixnum_t)Saccum);
RETURN_NUM_AS(vtomp(Saccum, nil), mpint);
}
#define ACCUM_DEFAULT 0
#define ARITH_OP(a, b) (a)+(b)
#define MP_OP mpadd
#define ARITH_OVERFLOW sadd_overflow_64
value_t
fl_add_any(value_t *args, uint32_t nargs)
{
#include "fl_arith_any.inc"
}
#define ACCUM_DEFAULT 1
#define ARITH_OP(a, b) (a)*(b)
#define MP_OP mpmul
#define ARITH_OVERFLOW smul_overflow_64
value_t
fl_mul_any(value_t *args, uint32_t nargs)
{
#include "fl_arith_any.inc"
}
value_t
fl_neg(value_t n)
{
int64_t i64;
uint64_t ui64;
mpint *mp;
numerictype_t pt;
fixnum_t pi;
void *a;
if(isfixnum(n)){
i64 = -(int64_t)numval(n);
i64neg:
return fits_fixnum(i64) ? fixnum(i64) : mk_mpint(vtomp(i64, nil));
}
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_INT8: return fixnum(-(fixnum_t)*(int8_t*)a);
case T_UINT8: return fixnum(-(fixnum_t)*(uint8_t*)a);
case T_INT16: return fixnum(-(fixnum_t)*(int16_t*)a);
case T_UINT16: return fixnum(-(fixnum_t)*(uint16_t*)a);
case T_UINT32:
i64 = -(int64_t)*(uint32_t*)a;
if(0){
case T_INT32:
i64 = -(int64_t)*(int32_t*)a;
}
goto i64neg;
case T_INT64:
i64 = *(int64_t*)a;
if(i64 == INT64_MIN)
return mk_mpint(uvtomp((uint64_t)INT64_MAX+1, nil));
i64 = -i64;
goto i64neg;
case T_UINT64:
ui64 = *(uint64_t*)a;
if(ui64 >= (uint64_t)INT64_MAX+1){
mp = uvtomp(ui64, nil);
mp->sign = -1;
return mk_mpint(mp);
}
i64 = -(int64_t)ui64;
goto i64neg;
case T_MPINT:
mp = mpcopy(*(mpint**)a);
mp->sign = -mp->sign;
return mk_mpint(mp);
}
}
type_error("number", n);
}
int
num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
{
cprim_t *cp;
cvalue_t *cv;
if(isfixnum(a)){
*pi = numval(a);
*pp = pi;
*pt = T_FIXNUM;
return 1;
}else if(iscprim(a)){
cp = ptr(a);
*pp = cp_data(cp);
*pt = cp_numtype(cp);
return 1;
}else if(iscvalue(a)){
cv = ptr(a);
*pp = cv_data(cv);
*pt = cv_class(cv)->numtype;
return valid_numtype(*pt);
}
return 0;
}
/*
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(value_t a, value_t b, bool eq, bool eqnans, bool typeerr)
{
fixnum_t ai, bi;
numerictype_t 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)
type_error("number", a);
return 2;
}
if(!num_to_ptr(b, &bi, &tb, &bptr)){
if(typeerr)
type_error("number", b);
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
DivideByZeroError(void)
{
lerrorf(FL(DivideError), "/: division by zero");
}
value_t
fl_div2(value_t a, value_t b)
{
double da, db;
fixnum_t ai, bi;
numerictype_t ta, tb;
void *aptr, *bptr;
if(!num_to_ptr(a, &ai, &ta, &aptr))
type_error("number", a);
if(!num_to_ptr(b, &bi, &tb, &bptr))
type_error("number", b);
da = conv_to_double(aptr, ta);
db = conv_to_double(bptr, tb);
if(db == 0 && tb < T_FLOAT) // exact 0
DivideByZeroError();
da = da/db;
if(ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
return return_from_int64((int64_t)da);
return mk_double(da);
}
value_t
fl_idiv2(value_t a, value_t b)
{
fixnum_t ai, bi;
numerictype_t ta, tb;
void *aptr, *bptr;
int64_t a64, b64;
mpint *x;
if(!num_to_ptr(a, &ai, &ta, &aptr))
type_error("number", a);
if(!num_to_ptr(b, &bi, &tb, &bptr))
type_error("number", b);
if(ta == T_MPINT){
if(tb == T_MPINT){
if(mpsignif(*(mpint**)bptr) == 0)
goto div_error;
x = mpnew(0);
mpdiv(*(mpint**)aptr, *(mpint**)bptr, x, nil);
return mk_mpint(x);
}else{
b64 = conv_to_int64(bptr, tb);
if(b64 == 0)
goto div_error;
x = tb == T_UINT64 ? uvtomp(b64, nil) : vtomp(b64, nil);
mpdiv(*(mpint**)aptr, x, x, nil);
return mk_mpint(x);
}
}
if(ta == T_UINT64){
if(tb == T_UINT64){
if(*(uint64_t*)bptr == 0)
goto div_error;
return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr);
}
b64 = conv_to_int64(bptr, tb);
if(b64 < 0)
return return_from_int64(-(int64_t)(*(uint64_t*)aptr / (uint64_t)(-b64)));
if(b64 == 0)
goto div_error;
return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64);
}
if(tb == T_UINT64){
if(*(uint64_t*)bptr == 0)
goto div_error;
a64 = conv_to_int64(aptr, ta);
if(a64 < 0)
return return_from_int64(-((int64_t)((uint64_t)(-a64) / *(uint64_t*)bptr)));
return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr);
}
b64 = conv_to_int64(bptr, tb);
if(b64 == 0)
goto div_error;
return return_from_int64(conv_to_int64(aptr, ta) / b64);
div_error:
DivideByZeroError();
}
static value_t
fl_bitwise_op(value_t a, value_t b, int opcode)
{
fixnum_t ai, bi;
numerictype_t ta, tb, itmp;
void *aptr = nil, *bptr = nil, *ptmp;
mpint *bmp = nil, *resmp = nil;
int64_t b64;
if(!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
type_error("integer", a);
if(!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
type_error("integer", b);
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_MPINT){
if(tb == T_MPINT){
bmp = *(mpint**)bptr;
resmp = mpnew(0);
}else{
bmp = conv_to_mpint(bptr, tb);
resmp = bmp;
}
b64 = 0;
}else
b64 = conv_to_int64(bptr, tb);
switch(opcode){
case 0:
switch(ta){
case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64);
case T_MPINT: mpand(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
break;
case 1:
switch(ta){
case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64);
case T_MPINT: mpor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
break;
case 2:
switch(ta){
case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64);
case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64);
case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64);
case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64);
case T_MPINT: mpxor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp);
case T_FLOAT:
case T_DOUBLE: assert(0);
}
}
assert(0);
return FL(Nil);
}
BUILTIN("logand", logand)
{
value_t v, e;
if(nargs == 0)
return fixnum(-1);
v = args[0];
uint32_t i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = v & e;
else
v = fl_bitwise_op(v, e, 0);
}
return v;
}
BUILTIN("logior", logior)
{
value_t v, e;
if(nargs == 0)
return fixnum(0);
v = args[0];
uint32_t i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = v | e;
else
v = fl_bitwise_op(v, e, 1);
}
return v;
}
BUILTIN("logxor", logxor)
{
value_t v, e;
if(nargs == 0)
return fixnum(0);
v = args[0];
uint32_t i;
FOR_ARGS(i, 1, e, args){
if(bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = fl_bitwise_op(v, e, 2);
}
return v;
}
BUILTIN("lognot", lognot)
{
argcount(nargs, 1);
value_t a = args[0];
cprim_t *cp;
int ta;
void *aptr;
if(isfixnum(a))
return fixnum(~numval(a));
if(iscprim(a)){
cp = ptr(a);
ta = cp_numtype(cp);
aptr = cp_data(cp);
switch(ta){
case T_INT8: return fixnum(~*(int8_t *)aptr);
case T_UINT8: return fixnum(~*(uint8_t *)aptr & 0xff);
case T_INT16: return fixnum(~*(int16_t *)aptr);
case T_UINT16: return fixnum(~*(uint16_t*)aptr & 0xffff);
case T_INT32: return mk_int32(~*(int32_t *)aptr);
case T_UINT32: return mk_uint32(~*(uint32_t*)aptr);
case T_INT64: return mk_int64(~*(int64_t *)aptr);
case T_UINT64: return mk_uint64(~*(uint64_t*)aptr);
}
}
if(iscvalue(a)){
cvalue_t *cv = ptr(a);
ta = cp_numtype(cv);
aptr = cv_data(cv);
if(ta == T_MPINT){
mpint *m = mpnew(0);
mpnot(*(mpint**)aptr, m);
return mk_mpint(m);
}
}
type_error("integer", a);
}
BUILTIN("ash", ash)
{
fixnum_t n;
int64_t accum;
cprim_t *cp;
int ta;
mpint *mp;
void *aptr;
argcount(nargs, 2);
value_t a = args[0];
n = tofixnum(args[1]);
if(isfixnum(a)){
if(n <= 0)
return fixnum(numval(a)>>(-n));
accum = ((int64_t)numval(a))<<n;
return fits_fixnum(accum) ? fixnum(accum) : return_from_int64(accum);
}
if(iscprim(a) || iscvalue(a)){
if(n == 0)
return a;
cp = ptr(a);
ta = cp_numtype(cp);
aptr = cp_data(cp);
if(n < 0){
n = -n;
switch(ta){
case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
case T_INT32: return mk_int32((*(int32_t *)aptr) >> n);
case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n);
case T_INT64: return mk_int64((*(int64_t *)aptr) >> n);
case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n);
case T_MPINT:
aptr = cv_data(cp);
mp = mpnew(0);
mpright(*(mpint**)aptr, n, mp);
return mk_mpint(mp);
}
}
if(ta == T_MPINT){
aptr = cv_data(cp);
mp = mpnew(0);
mpleft(*(mpint**)aptr, n, mp);
return mk_mpint(mp);
}
if(ta == T_UINT64)
return return_from_uint64((*(uint64_t*)aptr)<<n);
if(ta < T_FLOAT)
return return_from_int64(conv_to_int64(aptr, ta)<<n);
}
type_error("integer", a);
}
void
cvalues_init(void)
{
htable_new(&FL(TypeTable), 256);
htable_new(&FL(reverse_dlsym_lookup_table), 256);
FL(builtintype) = define_opaque_type(FL(builtinsym), sizeof(builtin_t), nil, nil);
ctor_cv_intern(int8, T_INT8, int8_t);
ctor_cv_intern(uint8, T_UINT8, uint8_t);
ctor_cv_intern(int16, T_INT16, int16_t);
ctor_cv_intern(uint16, T_UINT16, uint16_t);
ctor_cv_intern(int32, T_INT32, int32_t);
ctor_cv_intern(uint32, T_UINT32, uint32_t);
ctor_cv_intern(int64, T_INT64, int64_t);
ctor_cv_intern(uint64, T_UINT64, uint64_t);
ctor_cv_intern(byte, T_UINT8, uint8_t);
ctor_cv_intern(rune, T_UINT32, uint32_t);
ctor_cv_intern(float, T_FLOAT, float);
ctor_cv_intern(double, T_DOUBLE, double);
ctor_cv_intern(array, NONNUMERIC, int);
ctor_cv_intern(enum, NONNUMERIC, int);
cv_intern(pointer);
cv_intern(struct);
cv_intern(union);
cv_intern(void);
FL(cfunctionsym) = symbol("c-function", false);
FL(stringtypesym) = symbol("*string-type*", false);
set(FL(stringtypesym), fl_list2(FL(arraysym), FL(bytesym)));
FL(runestringtypesym) = symbol("*runestring-type*", false);
set(FL(runestringtypesym), fl_list2(FL(arraysym), FL(runesym)));
mk_primtype(int8, int8_t);
mk_primtype(uint8, uint8_t);
mk_primtype(int16, int16_t);
mk_primtype(uint16, uint16_t);
mk_primtype(int32, int32_t);
mk_primtype(uint32, uint32_t);
mk_primtype(int64, int64_t);
mk_primtype(uint64, uint64_t);
mk_primtype(byte, uint8_t);
mk_primtype(rune, uint32_t);
mk_primtype(float, float);
mk_primtype(double, double);
ctor_cv_intern(bignum, T_MPINT, mpint*);
FL(mpinttype) = get_type(FL(bignumsym));
FL(mpinttype)->init = cvalue_mpint_init;
FL(mpinttype)->vtable = &mpint_vtable;
FL(stringtype) = get_type(symbol_value(FL(stringtypesym)));
FL(runestringtype) = get_type(symbol_value(FL(runestringtypesym)));
FL(emptystringsym) = symbol("*empty-string*", false);
set(FL(emptystringsym), cvalue_static_cstring(""));
}