ref: 95a3f48ca4df8ee6ecd2cdd7b393f83f94f5c69f
dir: /cvalues.c/
#include "operators.c"
#ifdef BITS64
#define NWORDS(sz) (((sz)+7)>>3)
#else
#define NWORDS(sz) (((sz)+3)>>2)
#endif
value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
value_t int64sym, uint64sym;
value_t longsym, ulongsym, bytesym, wcharsym;
value_t floatsym, doublesym;
value_t gftypesym, stringtypesym, wcstringtypesym;
value_t emptystringsym;
value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
value_t unionsym;
static htable_t TypeTable;
static htable_t reverse_dlsym_lookup_table;
static fltype_t *int8type, *uint8type;
static fltype_t *int16type, *uint16type;
static fltype_t *int32type, *uint32type;
static fltype_t *int64type, *uint64type;
static fltype_t *longtype, *ulongtype;
static fltype_t *floattype, *doubletype;
fltype_t *bytetype, *wchartype;
fltype_t *stringtype, *wcstringtype;
fltype_t *builtintype;
static void cvalue_init(fltype_t *type, value_t v, void *dest);
// cvalues-specific builtins
value_t cvalue_new(value_t *args, uint32_t nargs);
value_t cvalue_sizeof(value_t *args, uint32_t nargs);
value_t cvalue_typeof(value_t *args, uint32_t nargs);
// trigger unconditional GC after this many bytes are allocated
#define ALLOC_LIMIT_TRIGGER 67108864
static size_t malloc_pressure = 0;
static cvalue_t **Finalizers = NULL;
static size_t nfinalizers=0;
static size_t maxfinalizers=0;
void add_finalizer(cvalue_t *cv)
{
if (nfinalizers == maxfinalizers) {
size_t nn = (maxfinalizers==0 ? 256 : maxfinalizers*2);
cvalue_t **temp = realloc(Finalizers, nn*sizeof(cvalue_t*));
if (temp == NULL)
lerrorf(MemoryError, "out of memory");
Finalizers = temp;
maxfinalizers = nn;
}
Finalizers[nfinalizers++] = cv;
}
// remove dead objects from finalization list in-place
static void sweep_finalizers(void)
{
cvalue_t **lst = Finalizers;
size_t n=0, ndel=0, l=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] = (cvalue_t*)ptr(forwardloc((value_t)tmp));
n++;
}
else {
fltype_t *t = cv_class(tmp);
if (t->vtable != NULL && t->vtable->finalize != NULL) {
t->vtable->finalize(tagptr(tmp, TAG_CVALUE));
}
if (!isinlined(tmp) && owned(tmp)) {
memset(cv_data(tmp), 0xbb, cv_len(tmp));
free(cv_data(tmp));
}
ndel++;
}
} while ((n < l-ndel) && SWAP_sf(lst[n],lst[n+ndel]));
nfinalizers -= ndel;
#ifdef VERBOSEGC
if (ndel > 0)
printf("GC: finalized %d objects\n", ndel);
#endif
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 = (cprim_t*)alloc_words(CPRIM_NWORDS-1+NWORDS(sz));
pcp->type = type;
return tagptr(pcp, TAG_CPRIM);
}
value_t cvalue(fltype_t *type, size_t sz)
{
cvalue_t *pcv;
int str=0;
if (valid_numtype(type->numtype))
return cprim(type, sz);
if (type->eltype == bytetype) {
if (sz == 0)
return symbol_value(emptystringsym);
sz++;
str=1;
}
if (sz <= MAX_INL_SIZE) {
size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0);
pcv = (cvalue_t*)alloc_words(nw);
pcv->type = type;
pcv->data = &pcv->_space[0];
if (type->vtable != NULL && type->vtable->finalize != NULL)
add_finalizer(pcv);
}
else {
if (malloc_pressure > ALLOC_LIMIT_TRIGGER)
gc(0);
pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
pcv->type = type;
pcv->data = malloc(sz);
autorelease(pcv);
malloc_pressure += sz;
}
if (str) {
sz--;
((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;
pcv = (cvalue_t*)alloc_words(CVALUE_NWORDS);
pcv->data = ptr;
pcv->len = sz;
pcv->type = type;
if (parent != 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(stringtype, sz);
}
value_t cvalue_static_cstring(const char *str)
{
return cvalue_from_ref(stringtype, (char*)str, strlen(str), 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 = malloc(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 = numval(arg); \
} \
else if (iscprim(arg)) { \
cprim_t *cp = (cprim_t*)ptr(arg); \
void *p = cp_data(cp); \
n = (ctype)conv_to_##cnvt(p, cp_numtype(cp)); \
} \
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) \
value_t cvalue_##typenam(value_t *args, uint32_t nargs) \
{ \
if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \
value_t cp = cprim(typenam##type, sizeof(ctype)); \
if (cvalue_##ctype##_init(typenam##type, \
args[0], cp_data((cprim_t*)ptr(cp)))) \
type_error(#typenam, "number", args[0]); \
return cp; \
}
#define num_ctor_ctor(typenam, ctype, tag) \
value_t mk_##typenam(ctype n) \
{ \
value_t cp = cprim(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(int8, int8_t, T_INT8)
num_ctor(uint8, uint8_t, T_UINT8)
num_ctor(int16, int16_t, T_INT16)
num_ctor(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(byte, uint8_t, T_UINT8)
num_ctor(wchar, int32_t, T_INT32)
#if defined(ULONG64)
num_ctor(long, int64_t, T_INT64)
num_ctor(ulong, uint64_t, T_UINT64)
#else
num_ctor(long, int32_t, T_INT32)
num_ctor(ulong, uint32_t, T_UINT32)
#endif
num_ctor(float, float, T_FLOAT)
num_ctor(double, double, T_DOUBLE)
value_t size_wrap(size_t sz)
{
if (fits_fixnum(sz))
return fixnum(sz);
assert(sizeof(void*) == sizeof(size_t));
return mk_ulong(sz);
}
size_t toulong(value_t n, char *fname)
{
if (isfixnum(n))
return numval(n);
if (iscprim(n)) {
cprim_t *cp = (cprim_t*)ptr(n);
return conv_to_ulong(cp_data(cp), cp_numtype(cp));
}
type_error(fname, "number", n);
return NIL;
}
static int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest)
{
int n=0;
value_t syms;
value_t type = ft->type;
syms = car(cdr(type));
if (!isvector(syms))
type_error("enum", "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(ArgError, "enum: 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("enum", "number", arg);
}
if ((unsigned)n >= vector_size(syms))
lerrorf(ArgError, "enum: value out of range");
*(int*)dest = n;
return 0;
}
value_t cvalue_enum(value_t *args, uint32_t nargs)
{
argcount("enum", nargs, 2);
value_t type = fl_list2(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;
}
static int isarray(value_t v)
{
return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
}
static size_t predict_arraylen(value_t arg)
{
if (isvector(arg))
return vector_size(arg);
else if (iscons(arg))
return llength(arg);
else if (arg == NIL)
return 0;
if (isarray(arg))
return cvalue_arraylen(arg);
return 1;
}
static 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 = toulong(car_(cdr_(cdr_(type))), "array");
if (tc != cnt)
lerrorf(ArgError, "array: 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;
}
else if (iscons(arg) || arg==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(ArgError, "array: size mismatch");
return 0;
}
else 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(ArgError, "array: size mismatch");
return 0;
}
else {
// TODO: initialize array from different type elements
lerrorf(ArgError, "array: element type mismatch");
}
}
}
if (cnt == 1)
cvalue_init(eltype, arg, dest);
else
type_error("array", "sequence", arg);
return 0;
}
value_t cvalue_array(value_t *args, uint32_t nargs)
{
size_t elsize, cnt, sz, i;
value_t arg;
if (nargs < 1)
argcount("array", 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 = cv_data((cvalue_t*)ptr(cv));
FOR_ARGS(i,1,arg,args) {
cvalue_init(type->eltype, arg, dest);
dest += elsize;
}
return cv;
}
// NOTE: v must be an array
size_t cvalue_arraylen(value_t v)
{
cvalue_t *cv = (cvalue_t*)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 = LLT_ALIGN(ssz, al);
if (al > *palign)
*palign = al;
if (!computeTotal && field==car_(car_(fld))) {
// found target field
return ssz;
}
ssz += fsz;
fld = cdr_(fld);
}
return LLT_ALIGN(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 LLT_ALIGN(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)) != NULL && valid_numtype(s->numtype)) {
*palign = s->align;
return s->size;
}
if (iscons(type)) {
value_t hed = car_(type);
if (hed == pointersym || hed == cfunctionsym) {
*palign = sizeof(struct { char a; void *i; }) - sizeof(void*);
return sizeof(void*);
}
if (hed == arraysym) {
value_t t = car(cdr_(type));
if (!iscons(cdr_(cdr_(type))))
lerrorf(ArgError, "sizeof: incomplete type");
value_t n = car_(cdr_(cdr_(type)));
size_t sz = toulong(n, "sizeof");
return sz * ctype_sizeof(t, palign);
}
else if (hed == structsym) {
return cvalue_struct_offs(type, NIL, 1, palign);
}
else if (hed == unionsym) {
return cvalue_union_size(type, palign);
}
else if (hed == enumsym) {
*palign = sizeof(struct { char c; numerictype_t e; }) - sizeof(numerictype_t);
return sizeof(numerictype_t);
}
}
lerrorf(ArgError, "sizeof: invalid c type");
return 0;
}
extern fltype_t *iostreamtype;
// get pointer and size for any plain-old-data value
void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
{
if (iscvalue(v)) {
cvalue_t *pcv = (cvalue_t*)ptr(v);
ios_t *x = value2c(ios_t*,v);
if (cv_class(pcv) == iostreamtype && (x->bm == bm_mem)) {
*pdata = x->buf;
*psz = x->size;
return;
}
else if (cv_isPOD(pcv)) {
*pdata = cv_data(pcv);
*psz = cv_len(pcv);
return;
}
}
else if (iscprim(v)) {
cprim_t *pcp = (cprim_t*)ptr(v);
*pdata = cp_data(pcp);
*psz = cp_class(pcp)->size;
return;
}
type_error(fname, "plain-old-data", v);
}
value_t cvalue_sizeof(value_t *args, uint32_t nargs)
{
argcount("sizeof", nargs, 1);
if (issymbol(args[0]) || iscons(args[0])) {
int a;
return size_wrap(ctype_sizeof(args[0], &a));
}
size_t n; char *data;
to_sized_ptr(args[0], "sizeof", &data, &n);
return size_wrap(n);
}
value_t cvalue_typeof(value_t *args, uint32_t nargs)
{
argcount("typeof", nargs, 1);
switch(tag(args[0])) {
case TAG_CONS: return pairsym;
case TAG_NUM1:
case TAG_NUM: return fixnumsym;
case TAG_SYM: return symbolsym;
case TAG_VECTOR: return vectorsym;
case TAG_FUNCTION:
if (args[0] == FL_T || args[0] == FL_F)
return booleansym;
if (args[0] == NIL)
return nullsym;
if (args[0] == FL_EOF)
return symbol("eof-object");
if (isbuiltin(args[0]))
return builtinsym;
return FUNCTION;
}
return cv_type((cvalue_t*)ptr(args[0]));
}
static value_t cvalue_relocate(value_t v)
{
size_t nw;
cvalue_t *cv = (cvalue_t*)ptr(v);
cvalue_t *nv;
value_t ncv;
nw = cv_nwords(cv);
nv = (cvalue_t*)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 != NULL && t->vtable->relocate != NULL)
t->vtable->relocate(v, ncv);
forward(v, ncv);
return ncv;
}
value_t cvalue_copy(value_t v)
{
assert(iscvalue(v));
PUSH(v);
cvalue_t *cv = (cvalue_t*)ptr(v);
size_t nw = cv_nwords(cv);
cvalue_t *ncv = (cvalue_t*)alloc_words(nw);
v = POP(); cv = (cvalue_t*)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 = malloc(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 = NIL;
}
}
else {
ncv->data = &ncv->_space[0];
}
return tagptr(ncv, TAG_CVALUE);
}
value_t fl_copy(value_t *args, uint32_t nargs)
{
argcount("copy", nargs, 1);
if (iscons(args[0]) || isvector(args[0]))
lerrorf(ArgError, "copy: argument must be a leaf atom");
if (!iscvalue(args[0]))
return args[0];
if (!cv_isPOD((cvalue_t*)ptr(args[0])))
lerrorf(ArgError, "copy: argument must be a plain-old-data type");
return cvalue_copy(args[0]);
}
value_t fl_podp(value_t *args, uint32_t nargs)
{
argcount("plain-old-data?", 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 == NULL)
lerrorf(ArgError, "c-value: 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.
value_t cvalue_new(value_t *args, uint32_t nargs)
{
if (nargs < 1 || nargs > 2)
argcount("c-value", nargs, 2);
value_t type = args[0];
fltype_t *ft = get_type(type);
value_t cv;
if (ft->eltype != NULL) {
// special case to handle incomplete array types bla[]
size_t elsz = ft->elsz;
size_t cnt;
if (iscons(cdr_(cdr_(type))))
cnt = toulong(car_(cdr_(cdr_(type))), "array");
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], cv_data((cvalue_t*)ptr(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 = (cvalue_t*)ptr(a);
cvalue_t *cb = (cvalue_t*)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);
else if (asz < bsz)
return fixnum(-1);
}
return fixnum(diff);
}
static void check_addr_args(char *fname, value_t arr, value_t ind,
char **data, int *index)
{
int numel;
cvalue_t *cv = (cvalue_t*)ptr(arr);
*data = cv_data(cv);
numel = cv_len(cv)/(cv_class(cv)->elsz);
*index = toulong(ind, fname);
if (*index >= numel)
bounds_error(fname, arr, ind);
}
static value_t cvalue_array_aref(value_t *args)
{
char *data; int index;
fltype_t *eltype = cv_class((cvalue_t*)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("aref", args[0], args[1], &data, &index);
if (nt < T_INT32) {
if (nt == T_INT8)
return fixnum((int8_t)data[index]);
else if (nt == T_UINT8)
return fixnum((uint8_t)data[index]);
else 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;
}
static value_t cvalue_array_aset(value_t *args)
{
char *data; int index;
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
check_addr_args("aset!", args[0], args[1], &data, &index);
char *dest = data + index*eltype->size;
cvalue_init(eltype, args[2], dest);
return args[2];
}
value_t fl_builtin(value_t *args, uint32_t nargs)
{
argcount("builtin", nargs, 1);
symbol_t *name = tosymbol(args[0], "builtin");
cvalue_t *cv = NULL;
if (ismanaged(args[0]) || (cv=name->dlcache) == NULL) {
lerrorf(ArgError, "builtin: function %s not found", name->name);
}
return tagptr(cv, TAG_CVALUE);
}
value_t cbuiltin(char *name, builtin_t f)
{
cvalue_t *cv;
cv = malloc(CVALUE_NWORDS * sizeof(*cv));
cv->type = builtintype;
cv->data = &cv->_space[0];
cv->len = sizeof(value_t);
*(void**)cv->data = f;
value_t sym = symbol(name);
((symbol_t*)ptr(sym))->dlcache = cv;
ptrhash_put(&reverse_dlsym_lookup_table, cv, (void*)sym);
return tagptr(cv, TAG_CVALUE);
}
static value_t fl_logand(value_t *args, uint32_t nargs);
static value_t fl_logior(value_t *args, uint32_t nargs);
static value_t fl_logxor(value_t *args, uint32_t nargs);
static value_t fl_lognot(value_t *args, uint32_t nargs);
static value_t fl_ash(value_t *args, uint32_t nargs);
static builtinspec_t cvalues_builtin_info[] = {
{ "c-value", cvalue_new },
{ "typeof", cvalue_typeof },
{ "sizeof", cvalue_sizeof },
{ "builtin", fl_builtin },
{ "copy", fl_copy },
{ "plain-old-data?", fl_podp },
{ "logand", fl_logand },
{ "logior", fl_logior },
{ "logxor", fl_logxor },
{ "lognot", fl_lognot },
{ "ash", fl_ash },
// todo: autorelease
{ NULL, NULL }
};
#define cv_intern(tok) \
do{ \
tok##sym = symbol(#tok); \
}while(0)
#define ctor_cv_intern(tok, nt, ctype) \
do{ \
symbol_t *s; \
cv_intern(tok); \
set(tok##sym, cbuiltin(#tok, cvalue_##tok)); \
if (valid_numtype(nt)) { \
s = ptr(tok##sym); \
s->numtype = nt; \
s->size = sizeof(ctype); \
s->align = sizeof(struct{char c; ctype x;}) - sizeof(ctype); \
} \
}while(0)
#define mk_primtype(name, ctype) \
do{ \
name##type=get_type(name##sym); \
name##type->init = cvalue_##ctype##_init; \
}while(0)
static void cvalues_init(void)
{
htable_new(&TypeTable, 256);
htable_new(&reverse_dlsym_lookup_table, 256);
builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), NULL, NULL);
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(wchar, T_INT32, int32_t);
#if defined(ULONG64)
ctor_cv_intern(long, T_INT64, int64_t);
ctor_cv_intern(ulong, T_UINT64, uint64_t);
#else
ctor_cv_intern(long, T_INT32, int32_t);
ctor_cv_intern(ulong, T_UINT32, uint32_t);
#endif
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);
cfunctionsym = symbol("c-function");
assign_global_builtins(cvalues_builtin_info);
stringtypesym = symbol("*string-type*");
setc(stringtypesym, fl_list2(arraysym, bytesym));
wcstringtypesym = symbol("*wcstring-type*");
setc(wcstringtypesym, fl_list2(arraysym, wcharsym));
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);
#if defined(ULONG64)
mk_primtype(long, int64_t);
mk_primtype(ulong, uint64_t);
#else
mk_primtype(long, int32_t);
mk_primtype(ulong, uint32_t);
#endif
mk_primtype(byte, uint8_t);
mk_primtype(wchar, int32_t);
mk_primtype(float, float);
mk_primtype(double, double);
stringtype = get_type(symbol_value(stringtypesym));
wcstringtype = get_type(symbol_value(wcstringtypesym));
emptystringsym = symbol("*empty-string*");
setc(emptystringsym, cvalue_static_cstring(""));
}
#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);
}
else if (Uaccum > (uint64_t)UINT32_MAX) {
RETURN_NUM_AS(Uaccum, int64);
}
else 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);
}
if (Saccum > (int64_t)UINT32_MAX || Saccum < (int64_t)INT32_MIN) {
RETURN_NUM_AS(Saccum, int64);
}
else if (Saccum > (int64_t)INT32_MAX) {
RETURN_NUM_AS(Saccum, uint32);
}
RETURN_NUM_AS(Saccum, int32);
}
static value_t fl_add_any(value_t *args, uint32_t nargs, fixnum_t carryIn)
{
uint64_t Uaccum=0;
int64_t Saccum = carryIn;
double Faccum=0;
int32_t inexact = 0;
uint32_t i;
value_t arg;
FOR_ARGS(i,0,arg,args) {
if (isfixnum(arg)) {
Saccum += numval(arg);
continue;
}
else if (iscprim(arg)) {
cprim_t *cp = (cprim_t*)ptr(arg);
void *a = cp_data(cp);
int64_t i64;
switch(cp_numtype(cp)) {
case T_INT8: Saccum += *(int8_t*)a; break;
case T_UINT8: Saccum += *(uint8_t*)a; break;
case T_INT16: Saccum += *(int16_t*)a; break;
case T_UINT16: Saccum += *(uint16_t*)a; break;
case T_INT32: Saccum += *(int32_t*)a; break;
case T_UINT32: Saccum += *(uint32_t*)a; break;
case T_INT64:
i64 = *(int64_t*)a;
if (i64 > 0)
Uaccum += (uint64_t)i64;
else
Saccum += i64;
break;
case T_UINT64: Uaccum += *(uint64_t*)a; break;
case T_FLOAT: Faccum += *(float*)a; inexact = 1; break;
case T_DOUBLE: Faccum += *(double*)a; inexact = 1; break;
default:
goto add_type_error;
}
continue;
}
add_type_error:
type_error("+", "number", arg);
}
if (inexact) {
Faccum += Uaccum;
Faccum += Saccum;
return mk_double(Faccum);
}
else if (Saccum < 0) {
uint64_t negpart = (uint64_t)(-Saccum);
if (negpart > Uaccum) {
Saccum += (int64_t)Uaccum;
// return value in Saccum
if (Saccum >= INT32_MIN) {
if (fits_fixnum(Saccum)) {
return fixnum((fixnum_t)Saccum);
}
RETURN_NUM_AS(Saccum, int32);
}
RETURN_NUM_AS(Saccum, int64);
}
Uaccum -= negpart;
}
else {
Uaccum += (uint64_t)Saccum;
}
// return value in Uaccum
return return_from_uint64(Uaccum);
}
static value_t fl_neg(value_t n)
{
if (isfixnum(n)) {
fixnum_t s = fixnum(-numval(n));
if (__unlikely((value_t)s == n))
return mk_xlong(-numval(n));
else
return s;
}
else if (iscprim(n)) {
cprim_t *cp = (cprim_t*)ptr(n);
void *a = cp_data(cp);
uint32_t ui32;
int32_t i32;
int64_t i64;
switch(cp_numtype(cp)) {
case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
case T_INT32:
i32 = *(int32_t*)a;
if (i32 == (int32_t)BIT31)
return mk_uint32((uint32_t)BIT31);
return mk_int32(-i32);
case T_UINT32:
ui32 = *(uint32_t*)a;
if (ui32 <= ((uint32_t)INT32_MAX)+1) return mk_int32(-(int32_t)ui32);
return mk_int64(-(int64_t)ui32);
case T_INT64:
i64 = *(int64_t*)a;
if (i64 == (int64_t)BIT63)
return mk_uint64((uint64_t)BIT63);
return mk_int64(-i64);
case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a);
case T_FLOAT: return mk_float(-*(float*)a);
case T_DOUBLE: return mk_double(-*(double*)a);
break;
}
}
type_error("-", "number", n);
return NIL;
}
static value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum)
{
uint64_t Uaccum=1;
double Faccum=1;
int32_t inexact = 0;
uint32_t i;
value_t arg;
FOR_ARGS(i,0,arg,args) {
if (isfixnum(arg)) {
Saccum *= numval(arg);
continue;
}
else if (iscprim(arg)) {
cprim_t *cp = (cprim_t*)ptr(arg);
void *a = cp_data(cp);
int64_t i64;
switch(cp_numtype(cp)) {
case T_INT8: Saccum *= *(int8_t*)a; break;
case T_UINT8: Saccum *= *(uint8_t*)a; break;
case T_INT16: Saccum *= *(int16_t*)a; break;
case T_UINT16: Saccum *= *(uint16_t*)a; break;
case T_INT32: Saccum *= *(int32_t*)a; break;
case T_UINT32: Saccum *= *(uint32_t*)a; break;
case T_INT64:
i64 = *(int64_t*)a;
if (i64 > 0)
Uaccum *= (uint64_t)i64;
else
Saccum *= i64;
break;
case T_UINT64: Uaccum *= *(uint64_t*)a; break;
case T_FLOAT: Faccum *= *(float*)a; inexact = 1; break;
case T_DOUBLE: Faccum *= *(double*)a; inexact = 1; break;
default:
goto mul_type_error;
}
continue;
}
mul_type_error:
type_error("*", "number", arg);
}
if (inexact) {
Faccum *= Uaccum;
Faccum *= Saccum;
return mk_double(Faccum);
}
else if (Saccum < 0) {
Saccum *= (int64_t)Uaccum;
if (Saccum >= INT32_MIN) {
if (fits_fixnum(Saccum)) {
return fixnum((fixnum_t)Saccum);
}
RETURN_NUM_AS(Saccum, int32);
}
RETURN_NUM_AS(Saccum, int64);
}
else {
Uaccum *= (uint64_t)Saccum;
}
return return_from_uint64(Uaccum);
}
static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
{
cprim_t *cp;
if (isfixnum(a)) {
*pi = numval(a);
*pp = pi;
*pt = T_FIXNUM;
}
else if (iscprim(a)) {
cp = (cprim_t*)ptr(a);
*pp = cp_data(cp);
*pt = cp_numtype(cp);
}
else {
return 0;
}
return 1;
}
/*
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
fname: if not NULL, throws type errors, else returns 2 for type errors
*/
int numeric_compare(value_t a, value_t b, int eq, int eqnans, char *fname)
{
lltint_t ai, bi;
numerictype_t ta, tb;
void *aptr, *bptr;
if (bothfixnums(a,b)) {
if (a==b) return 0;
if (numval(a) < numval(b)) return -1;
return 1;
}
if (!num_to_ptr(a, &ai, &ta, &aptr)) {
if (fname) type_error(fname, "number", a); else return 2;
}
if (!num_to_ptr(b, &bi, &tb, &bptr)) {
if (fname) type_error(fname, "number", b); else 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;
}
static void DivideByZeroError(void) __attribute__ ((__noreturn__));
static void DivideByZeroError(void)
{
lerrorf(DivideError, "/: division by zero");
}
static value_t fl_div2(value_t a, value_t b)
{
double da, db;
lltint_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);
}
static value_t fl_idiv2(value_t a, value_t b)
{
lltint_t ai, bi;
numerictype_t ta, tb;
void *aptr, *bptr;
int64_t a64, b64;
if (!num_to_ptr(a, &ai, &ta, &aptr))
type_error("div0", "number", a);
if (!num_to_ptr(b, &bi, &tb, &bptr))
type_error("div0", "number", b);
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();
return -1;
}
static value_t fl_bitwise_op(value_t a, value_t b, int opcode, char *fname)
{
lltint_t ai, bi;
numerictype_t ta, tb, itmp;
void *aptr=NULL, *bptr=NULL, *ptmp;
int64_t b64;
if (!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
type_error(fname, "integer", a);
if (!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
type_error(fname, "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
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_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_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_FLOAT:
case T_DOUBLE: assert(0);
}
}
assert(0);
return NIL;
}
static value_t fl_logand(value_t *args, uint32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(-1);
v = args[0];
FOR_ARGS(i,1,e,args) {
if (bothfixnums(v, e))
v = v & e;
else
v = fl_bitwise_op(v, e, 0, "logand");
}
return v;
}
static value_t fl_logior(value_t *args, uint32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(0);
v = args[0];
FOR_ARGS(i,1,e,args) {
if (bothfixnums(v, e))
v = v | e;
else
v = fl_bitwise_op(v, e, 1, "logior");
}
return v;
}
static value_t fl_logxor(value_t *args, uint32_t nargs)
{
value_t v, e;
int i;
if (nargs == 0)
return fixnum(0);
v = args[0];
FOR_ARGS(i,1,e,args) {
if (bothfixnums(v, e))
v = fixnum(numval(v) ^ numval(e));
else
v = fl_bitwise_op(v, e, 2, "logxor");
}
return v;
}
static value_t fl_lognot(value_t *args, uint32_t nargs)
{
argcount("lognot", nargs, 1);
value_t a = args[0];
if (isfixnum(a))
return fixnum(~numval(a));
cprim_t *cp;
int ta;
void *aptr;
if (iscprim(a)) {
cp = (cprim_t*)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);
}
}
type_error("lognot", "integer", a);
return NIL;
}
static value_t fl_ash(value_t *args, uint32_t nargs)
{
fixnum_t n;
int64_t accum;
argcount("ash", nargs, 2);
value_t a = args[0];
n = tofixnum(args[1], "ash");
if (isfixnum(a)) {
if (n <= 0)
return fixnum(numval(a)>>(-n));
accum = ((int64_t)numval(a))<<n;
if (fits_fixnum(accum))
return fixnum(accum);
else
return return_from_int64(accum);
}
cprim_t *cp;
int ta;
void *aptr;
if (iscprim(a)) {
if (n == 0) return a;
cp = (cprim_t*)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);
}
}
else {
if (ta == T_UINT64)
return return_from_uint64((*(uint64_t*)aptr)<<n);
else if (ta < T_FLOAT) {
int64_t i64 = conv_to_int64(aptr, ta);
return return_from_int64(i64<<n);
}
}
}
type_error("ash", "integer", a);
return NIL;
}