// strange comparisons are resolved arbitrarily but consistently. // ordering: number < cprim < function < vector < cvalue < symbol < cons static value_t bounded_compare(value_t a, value_t b, int bound, int eq) { value_t d; compare_top: if (a == b) return fixnum(0); if (bound <= 0) return NIL; int taga = tag(a); int tagb = cmptag(b); int c; switch (taga) { case TAG_NUM : case TAG_NUM1: if (isfixnum(b)) { return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); } if (iscprim(b)) { if (cp_class((cprim_t*)ptr(b)) == wchartype) return fixnum(1); return fixnum(numeric_compare(a, b, eq, 1, NULL)); } return fixnum(-1); case TAG_SYM: if (eq) return fixnum(1); if (tagb < TAG_SYM) return fixnum(1); if (tagb > TAG_SYM) return fixnum(-1); return fixnum(strcmp(symbol_name(a), symbol_name(b))); case TAG_VECTOR: if (isvector(b)) return bounded_vector_compare(a, b, bound, eq); break; case TAG_CPRIM: if (cp_class((cprim_t*)ptr(a)) == wchartype) { if (!iscprim(b) || cp_class((cprim_t*)ptr(b)) != wchartype) return fixnum(-1); } else if (iscprim(b) && cp_class((cprim_t*)ptr(b)) == wchartype) { return fixnum(1); } c = numeric_compare(a, b, eq, 1, NULL); if (c != 2) return fixnum(c); break; case TAG_CVALUE: if (iscvalue(b)) { if (cv_isPOD((cvalue_t*)ptr(a)) && cv_isPOD((cvalue_t*)ptr(b))) return cvalue_compare(a, b); return fixnum(1); } break; case TAG_FUNCTION: if (tagb == TAG_FUNCTION) { if (uintval(a) > N_BUILTINS && uintval(b) > N_BUILTINS) { function_t *fa = (function_t*)ptr(a); function_t *fb = (function_t*)ptr(b); d = bounded_compare(fa->bcode, fb->bcode, bound-1, eq); if (d==NIL || numval(d) != 0) return d; d = bounded_compare(fa->vals, fb->vals, bound-1, eq); if (d==NIL || numval(d) != 0) return d; d = bounded_compare(fa->env, fb->env, bound-1, eq); if (d==NIL || numval(d) != 0) return d; return fixnum(0); } return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); } break; case TAG_CONS: if (tagb < TAG_CONS) return fixnum(1); d = bounded_compare(car_(a), car_(b), bound-1, eq); if (d==NIL || numval(d) != 0) return d; a = cdr_(a); b = cdr_(b); bound--; goto compare_top; } return (taga < tagb) ? fixnum(-1) : fixnum(1); }
void fl_print_child(ios_t *f, value_t v) { char *name, *str; char buf[64]; if (print_level >= 0 && P_LEVEL >= print_level && (iscons(v) || isvector(v) || isclosure(v))) { outc('#', f); return; } P_LEVEL++; switch (tag(v)) { case TAG_NUM : case TAG_NUM1: //HPOS+=ios_printf(f, "%ld", numval(v)); break; str = uint2str(&buf[1], sizeof(buf)-1, labs(numval(v)), 10); if (numval(v)<0) *(--str) = '-'; outs(str, f); break; case TAG_SYM: name = symbol_name(v); if (print_princ) outs(name, f); else if (ismanaged(v)) { outsn("#:", f, 2); outs(name, f); } else print_symbol_name(f, name); break; case TAG_FUNCTION: if (v == FL_T) { outsn("#t", f, 2); } else if (v == FL_F) { outsn("#f", f, 2); } else if (v == FL_NIL) { outsn("()", f, 2); } else if (v == FL_EOF) { outsn("#<eof>", f, 6); } else if (isbuiltin(v)) { if (!print_princ) outsn("#.", f, 2); outs(builtin_names[uintval(v)], f); } else { assert(isclosure(v)); if (!print_princ) { if (print_circle_prefix(f, v)) break; function_t *fn = (function_t*)ptr(v); outs("#fn(", f); char *data = cvalue_data(fn->bcode); size_t i, sz = cvalue_len(fn->bcode); for(i=0; i < sz; i++) data[i] += 48; fl_print_child(f, fn->bcode); for(i=0; i < sz; i++) data[i] -= 48; outc(' ', f); fl_print_child(f, fn->vals); if (fn->env != NIL) { outc(' ', f); fl_print_child(f, fn->env); } if (fn->name != LAMBDA) { outc(' ', f); fl_print_child(f, fn->name); } outc(')', f); } else { outs("#<function>", f); } } break; case TAG_CVALUE: case TAG_CPRIM: if (v == UNBOUND) { outs("#<undefined>", f); break; } case TAG_VECTOR: case TAG_CONS: if (print_circle_prefix(f, v)) break; if (isvector(v)) { outc('[', f); int newindent = HPOS, est; int i, sz = vector_size(v); for(i=0; i < sz; i++) { if (print_length >= 0 && i >= print_length && i < sz-1) { outsn("...", f, 3); break; } fl_print_child(f, vector_elt(v,i)); if (i < sz-1) { if (!print_pretty) { outc(' ', f); } else { est = lengthestimate(vector_elt(v,i+1)); if (HPOS > SCR_WIDTH-4 || (est!=-1 && (HPOS+est > SCR_WIDTH-2)) || (HPOS > SCR_WIDTH/2 && !smallp(vector_elt(v,i+1)) && !tinyp(vector_elt(v,i)))) newindent = outindent(newindent, f); else outc(' ', f); } } } outc(']', f); break; } if (iscvalue(v) || iscprim(v)) cvalue_print(f, v); else print_pair(f, v); break; } P_LEVEL--; }
// *oob: output argument, means we hit the limit specified by 'bound' static uptrint_t bounded_hash(value_t a, int bound, int *oob) { *oob = 0; union { double d; int64_t i64; } u; numerictype_t nt; size_t i, len; cvalue_t *cv; cprim_t *cp; void *data; uptrint_t h = 0; int oob2, tg = tag(a); switch(tg) { case TAG_NUM : case TAG_NUM1: u.d = (double)numval(a); return doublehash(u.i64); case TAG_FUNCTION: if (uintval(a) > N_BUILTINS) return bounded_hash(((function_t*)ptr(a))->bcode, bound, oob); return inthash(a); case TAG_SYM: return ((symbol_t*)ptr(a))->hash; case TAG_CPRIM: cp = (cprim_t*)ptr(a); data = cp_data(cp); if (cp_class(cp) == wchartype) return inthash(*(int32_t*)data); nt = cp_numtype(cp); u.d = conv_to_double(data, nt); return doublehash(u.i64); case TAG_CVALUE: cv = (cvalue_t*)ptr(a); data = cv_data(cv); return memhash(data, cv_len(cv)); case TAG_VECTOR: if (bound <= 0) { *oob = 1; return 1; } len = vector_size(a); for(i=0; i < len; i++) { h = MIX(h, bounded_hash(vector_elt(a,i), bound/2, &oob2)^1); if (oob2) bound/=2; *oob = *oob || oob2; } return h; case TAG_CONS: do { if (bound <= 0) { *oob = 1; return h; } h = MIX(h, bounded_hash(car_(a), bound/2, &oob2)); // bounds balancing: try to share the bounds efficiently // so we can hash better when a list is cdr-deep (a common case) if (oob2) bound/=2; else bound--; // recursive OOB propagation. otherwise this case is slow: // (hash '#2=((#0=(#1=(#1#) . #0#)) . #2#)) *oob = *oob || oob2; a = cdr_(a); } while (iscons(a)); h = MIX(h, bounded_hash(a, bound-1, &oob2)^2); *oob = *oob || oob2; return h; } return 0; }