304 lines
8.5 KiB
C
304 lines
8.5 KiB
C
value_t prim_types[32];
|
|
value_t *prim_sym_addrs[] = {
|
|
&int8sym, &uint8sym, &int16sym, &uint16sym, &int32sym, &uint32sym,
|
|
&int64sym, &uint64sym, &charsym, &ucharsym, &shortsym, &ushortsym,
|
|
&intsym, &uintsym, &longsym, &ulongsym,
|
|
&lispvaluesym };
|
|
#define N_PRIMSYMS (sizeof(prim_sym_addrs) / sizeof(value_t*))
|
|
|
|
static value_t cv_type(cvalue_t *cv)
|
|
{
|
|
if (cv->flags.prim) {
|
|
return prim_types[cv->flags.primtype];
|
|
}
|
|
return cv->type;
|
|
}
|
|
|
|
|
|
double t0,t1;
|
|
int i;
|
|
int32_t i32;
|
|
char s8;
|
|
ulong_t c8=3;
|
|
t0 = clock(); //0.058125017
|
|
set_secret_symtag(ulongsym,TAG_UINT32);
|
|
set_secret_symtag(int8sym,TAG_INT8);
|
|
for(i=0; i < 8000000; i++) {
|
|
cnvt_to_int32(&i32, &s8, int8sym);
|
|
c8+=c8;
|
|
s8+=s8;
|
|
}
|
|
t1 = clock();
|
|
printf("%d. that took %.16f\n", i32, t1-t0);
|
|
|
|
|
|
#define int_converter(type) \
|
|
static int cnvt_to_##type(type##_t *i, void *data, value_t type) \
|
|
{ \
|
|
if (type==int32sym) *i = *(int32_t*)data; \
|
|
else if (type==charsym) *i = *(char*)data; \
|
|
else if (type==ulongsym) *i = *(ulong*)data; \
|
|
else if (type==uint32sym) *i = *(uint32_t*)data; \
|
|
else if (type==int8sym) *i = *(int8_t*)data; \
|
|
else if (type==uint8sym) *i = *(uint8_t*)data; \
|
|
else if (type==int64sym) *i = *(int64_t*)data; \
|
|
else if (type==uint64sym) *i = *(uint64_t*)data; \
|
|
else if (type==wcharsym) *i = *(wchar_t*)data; \
|
|
else if (type==longsym) *i = *(long*)data; \
|
|
else if (type==int16sym) *i = *(int16_t*)data; \
|
|
else if (type==uint16sym) *i = *(uint16_t*)data; \
|
|
else \
|
|
return 1; \
|
|
return 0; \
|
|
}
|
|
int_converter(int32)
|
|
int_converter(uint32)
|
|
int_converter(int64)
|
|
int_converter(uint64)
|
|
|
|
#ifdef BITS64
|
|
#define cnvt_to_ulong(i,d,t) cnvt_to_uint64(i,d,t)
|
|
#else
|
|
#define cnvt_to_ulong(i,d,t) cnvt_to_uint32(i,d,t)
|
|
#endif
|
|
|
|
long intabs(long n)
|
|
{
|
|
long s = n>>(NBITS-1); // either -1 or 0
|
|
return (n^s) - s;
|
|
}
|
|
|
|
value_t fl_inv(value_t b)
|
|
{
|
|
int_t bi;
|
|
int tb;
|
|
void *bptr=NULL;
|
|
cvalue_t *cv;
|
|
|
|
if (isfixnum(b)) {
|
|
bi = numval(b);
|
|
if (bi == 0)
|
|
goto inv_error;
|
|
else if (bi == 1)
|
|
return fixnum(1);
|
|
else if (bi == -1)
|
|
return fixnum(-1);
|
|
return fixnum(0);
|
|
}
|
|
else if (iscvalue(b)) {
|
|
cv = (cvalue_t*)ptr(b);
|
|
tb = cv_numtype(cv);
|
|
if (tb <= T_DOUBLE)
|
|
bptr = cv_data(cv);
|
|
}
|
|
if (bptr == NULL)
|
|
type_error("/", "number", b);
|
|
|
|
if (tb == T_FLOAT)
|
|
return mk_double(1.0/(double)*(float*)bptr);
|
|
if (tb == T_DOUBLE)
|
|
return mk_double(1.0 / *(double*)bptr);
|
|
|
|
if (tb == T_UINT64) {
|
|
if (*(uint64_t*)bptr > 1)
|
|
return fixnum(0);
|
|
else if (*(uint64_t*)bptr == 1)
|
|
return fixnum(1);
|
|
goto inv_error;
|
|
}
|
|
int64_t b64 = conv_to_int64(bptr, tb);
|
|
if (b64 == 0) goto inv_error;
|
|
else if (b64 == 1) return fixnum(1);
|
|
else if (b64 == -1) return fixnum(-1);
|
|
|
|
return fixnum(0);
|
|
inv_error:
|
|
lerror(DivideError, "/: division by zero");
|
|
}
|
|
|
|
static void printstack(value_t *penv, uint32_t envsz)
|
|
{
|
|
int i;
|
|
printf("env=%d, size=%d\n", penv - &Stack[0], envsz);
|
|
for(i=0; i < SP; i++) {
|
|
printf("%d: ", i);
|
|
print(stdout, Stack[i], 0);
|
|
printf("\n");
|
|
}
|
|
printf("\n");
|
|
}
|
|
|
|
// unordered comparison
|
|
// not any faster than ordered comparison
|
|
|
|
// a is a fixnum, b is a cvalue
|
|
static value_t equal_num_cvalue(value_t a, value_t b)
|
|
{
|
|
cvalue_t *bcv = (cvalue_t*)ptr(b);
|
|
numerictype_t bt;
|
|
if (valid_numtype(bt=cv_numtype(bcv))) {
|
|
fixnum_t ia = numval(a);
|
|
void *bptr = cv_data(bcv);
|
|
if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
|
|
return fixnum(0);
|
|
}
|
|
return fixnum(1);
|
|
}
|
|
|
|
static value_t bounded_equal(value_t a, value_t b, int bound);
|
|
static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table);
|
|
|
|
static value_t bounded_vector_equal(value_t a, value_t b, int bound)
|
|
{
|
|
size_t la = vector_size(a);
|
|
size_t lb = vector_size(b);
|
|
if (la != lb) return fixnum(1);
|
|
size_t i;
|
|
for (i = 0; i < la; i++) {
|
|
value_t d = bounded_equal(vector_elt(a,i), vector_elt(b,i), bound-1);
|
|
if (d==NIL || numval(d)!=0) return d;
|
|
}
|
|
return fixnum(0);
|
|
}
|
|
|
|
static value_t bounded_equal(value_t a, value_t b, int bound)
|
|
{
|
|
value_t d;
|
|
|
|
compare_top:
|
|
if (a == b) return fixnum(0);
|
|
if (bound <= 0)
|
|
return NIL;
|
|
int taga = tag(a);
|
|
int tagb = cmptag(b);
|
|
switch (taga) {
|
|
case TAG_NUM :
|
|
case TAG_NUM1:
|
|
if (isfixnum(b)) {
|
|
return fixnum(1);
|
|
}
|
|
if (iscvalue(b)) {
|
|
return equal_num_cvalue(a, b);
|
|
}
|
|
return fixnum(1);
|
|
case TAG_SYM:
|
|
return fixnum(1);
|
|
case TAG_VECTOR:
|
|
if (isvector(b))
|
|
return bounded_vector_equal(a, b, bound);
|
|
break;
|
|
case TAG_CVALUE:
|
|
if (iscvalue(b)) {
|
|
cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b);
|
|
numerictype_t at, bt;
|
|
if (valid_numtype(at=cv_numtype(acv)) &&
|
|
valid_numtype(bt=cv_numtype(bcv))) {
|
|
void *aptr = cv_data(acv);
|
|
void *bptr = cv_data(bcv);
|
|
if (cmp_eq(aptr, at, bptr, bt))
|
|
return fixnum(0);
|
|
return fixnum(1);
|
|
}
|
|
return cvalue_compare(a, b);
|
|
}
|
|
else if (isfixnum(b)) {
|
|
return equal_num_cvalue(b, a);
|
|
}
|
|
break;
|
|
case TAG_BUILTIN:
|
|
return fixnum(1);
|
|
case TAG_CONS:
|
|
if (tagb != TAG_CONS) return fixnum(1);
|
|
d = bounded_equal(car_(a), car_(b), bound-1);
|
|
if (d==NIL || numval(d) != 0) return d;
|
|
a = cdr_(a); b = cdr_(b);
|
|
bound--;
|
|
goto compare_top;
|
|
}
|
|
return fixnum(1);
|
|
}
|
|
|
|
static value_t cyc_vector_equal(value_t a, value_t b, ptrhash_t *table)
|
|
{
|
|
size_t la = vector_size(a);
|
|
size_t lb = vector_size(b);
|
|
size_t i;
|
|
value_t d, xa, xb, ca, cb;
|
|
if (la != lb) return fixnum(1);
|
|
|
|
// first try to prove them different with no recursion
|
|
for (i = 0; i < la; i++) {
|
|
xa = vector_elt(a,i);
|
|
xb = vector_elt(b,i);
|
|
if (leafp(xa) || leafp(xb)) {
|
|
d = bounded_equal(xa, xb, 1);
|
|
if (numval(d)!=0) return d;
|
|
}
|
|
else if (cmptag(xa) != cmptag(xb)) {
|
|
return fixnum(1);
|
|
}
|
|
}
|
|
|
|
ca = eq_class(table, a);
|
|
cb = eq_class(table, b);
|
|
if (ca!=NIL && ca==cb)
|
|
return fixnum(0);
|
|
|
|
eq_union(table, a, b, ca, cb);
|
|
|
|
for (i = 0; i < la; i++) {
|
|
xa = vector_elt(a,i);
|
|
xb = vector_elt(b,i);
|
|
if (!leafp(xa) && !leafp(xb)) {
|
|
d = cyc_equal(xa, xb, table);
|
|
if (numval(d)!=0) return d;
|
|
}
|
|
}
|
|
|
|
return fixnum(0);
|
|
}
|
|
|
|
static value_t cyc_equal(value_t a, value_t b, ptrhash_t *table)
|
|
{
|
|
if (a==b)
|
|
return fixnum(0);
|
|
if (iscons(a)) {
|
|
if (iscons(b)) {
|
|
value_t aa = car_(a); value_t da = cdr_(a);
|
|
value_t ab = car_(b); value_t db = cdr_(b);
|
|
int tagaa = cmptag(aa); int tagda = cmptag(da);
|
|
int tagab = cmptag(ab); int tagdb = cmptag(db);
|
|
value_t d, ca, cb;
|
|
if (leafp(aa) || leafp(ab)) {
|
|
d = bounded_equal(aa, ab, 1);
|
|
if (numval(d)!=0) return d;
|
|
}
|
|
else if (tagaa != tagab)
|
|
return fixnum(1);
|
|
if (leafp(da) || leafp(db)) {
|
|
d = bounded_equal(da, db, 1);
|
|
if (numval(d)!=0) return d;
|
|
}
|
|
else if (tagda != tagdb)
|
|
return fixnum(1);
|
|
|
|
ca = eq_class(table, a);
|
|
cb = eq_class(table, b);
|
|
if (ca!=NIL && ca==cb)
|
|
return fixnum(0);
|
|
|
|
eq_union(table, a, b, ca, cb);
|
|
d = cyc_equal(aa, ab, table);
|
|
if (numval(d)!=0) return d;
|
|
return cyc_equal(da, db, table);
|
|
}
|
|
else {
|
|
return fixnum(1);
|
|
}
|
|
}
|
|
else if (isvector(a) && isvector(b)) {
|
|
return cyc_vector_equal(a, b, table);
|
|
}
|
|
return bounded_equal(a, b, 1);
|
|
}
|