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); }