ref: a7bb3ba3b42eaed8425699bbff9a45510ec895af
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("")); }