diff --git a/femtolisp/FLOSSING b/femtolisp/FLOSSING new file mode 100644 index 0000000..fa208ac --- /dev/null +++ b/femtolisp/FLOSSING @@ -0,0 +1,13 @@ +Flossing is important to overall oral health. + +Even by itself, flossing does a good job of cleaning teeth and gums, +and is the only way to clean below the gumline. + +However it has an important secondary purpose as well. Most people assume +the point of brushing teeth is to scrub the teeth with bristles. This +is not fully true; the more significant purpose of brushing is to apply +fluoride to teeth. If you don't floss, food particles are left between +the teeth and gums, blocking fluoride from reaching tooth surfaces. It +is then as if you were not brushing at all. Even if no material is +visible between teeth, there is probably some there. Flossing can pull +a surprising amount of gunk from a mouth that appears totally clean. diff --git a/femtolisp/attic/trash.c b/femtolisp/attic/trash.c index 4b5acad..7d0e8c2 100644 --- a/femtolisp/attic/trash.c +++ b/femtolisp/attic/trash.c @@ -127,3 +127,177 @@ static void printstack(value_t *penv, uint32_t envsz) } 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); +} diff --git a/femtolisp/equal.c b/femtolisp/equal.c index 4fe6cad..a31c722 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -30,8 +30,10 @@ static void eq_union(ptrhash_t *table, value_t a, value_t b, ptrhash_put(table, (void*)b, (void*)ca); } +// ordered comparison + // a is a fixnum, b is a cvalue -static int compare_num_cvalue(value_t a, value_t b) +static value_t compare_num_cvalue(value_t a, value_t b) { cvalue_t *bcv = (cvalue_t*)ptr(b); numerictype_t bt; @@ -39,14 +41,14 @@ static int compare_num_cvalue(value_t a, value_t b) fixnum_t ia = numval(a); void *bptr = cv_data(bcv); if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) - return 0; + return fixnum(0); if (cmp_lt(&ia, T_FIXNUM, bptr, bt)) - return -1; + return fixnum(-1); } else { - return -1; + return fixnum(-1); } - return 1; + return fixnum(1); } static value_t bounded_compare(value_t a, value_t b, int bound); @@ -86,7 +88,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound) return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); } if (iscvalue(b)) { - return fixnum(compare_num_cvalue(a, b)); + return compare_num_cvalue(a, b); } return fixnum(-1); case TAG_SYM: @@ -114,7 +116,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound) return cvalue_compare(a, b); } else if (isfixnum(b)) { - return fixnum(-compare_num_cvalue(b, a)); + return fixnum(-numval(compare_num_cvalue(b, a))); } break; case TAG_BUILTIN: @@ -125,7 +127,7 @@ static value_t bounded_compare(value_t a, value_t b, int bound) case TAG_CONS: if (tagb < TAG_CONS) return fixnum(1); d = bounded_compare(car_(a), car_(b), bound-1); - if (numval(d) != 0) return d; + if (d==NIL || numval(d) != 0) return d; a = cdr_(a); b = cdr_(b); bound--; goto compare_top; @@ -227,24 +229,31 @@ static value_t cyc_compare(value_t a, value_t b, ptrhash_t *table) return bounded_compare(a, b, 1); } +static ptrhash_t equal_eq_hashtable; +void comparehash_init() +{ + ptrhash_new(&equal_eq_hashtable, 512); +} + value_t compare(value_t a, value_t b) { - ptrhash_t h; value_t guess = bounded_compare(a, b, 2048); - if (guess != NIL) - return guess; - - ptrhash_new(&h, 512); - guess = cyc_compare(a, b, &h); - ptrhash_free(&h); + if (guess == NIL) { + guess = cyc_compare(a, b, &equal_eq_hashtable); + ptrhash_reset(&equal_eq_hashtable, 512); + } return guess; } +value_t equal(value_t a, value_t b) +{ + return (numval(compare(a,b))==0 ? T : NIL); +} + /* optimizations: - use hash updates instead of calling lookup then insert. i.e. get the bp once and use it twice. - - preallocate hash table and call reset() instead of new/free - - specialized version for equal (unordered comparison) + * preallocate hash table and call reset() instead of new/free * less redundant tag checking, 3-bit tags */ diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 66b74d4..769eb72 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -559,8 +559,6 @@ static value_t vector_grow(value_t v) return POP(); } -extern value_t compare(value_t a, value_t b); - int isnumber(value_t v) { return (isfixnum(v) || @@ -900,7 +898,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; } else if (v == wcharsym) { - v = fixnum(u8_charlen(*(wchar_t*)cv_data(cv))); + v = fixnum(u8_charlen(*(uint32_t*)cv_data(cv))); break; } } @@ -1099,7 +1097,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL; } else { - v = (compare(Stack[SP-2], Stack[SP-1])==0) ? T : NIL; + v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? T : NIL; } break; case F_EVAL: @@ -1301,6 +1299,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) // initialization ------------------------------------------------------------- extern void builtins_init(); +extern void comparehash_init(); void lisp_init(void) { @@ -1314,6 +1313,7 @@ void lisp_init(void) lim = curheap+heapsize-sizeof(cons_t); consflags = bitvector_new(heapsize/sizeof(cons_t), 1); ptrhash_new(&printconses, 32); + comparehash_init(); NIL = symbol("nil"); setc(NIL, NIL); T = symbol("T"); setc(T, T); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 4ebe40a..8b3fe8c 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -121,7 +121,8 @@ char *symbol_name(value_t v); value_t alloc_vector(size_t n, int init); size_t llength(value_t v); value_t list_nth(value_t l, size_t n); -value_t compare(value_t a, value_t b); +value_t compare(value_t a, value_t b); // -1, 0, or 1 +value_t equal(value_t a, value_t b); // T or nil /* safe casts */ cons_t *tocons(value_t v, char *fname); diff --git a/femtolisp/string.c b/femtolisp/string.c index beda106..ea31bbf 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -99,7 +99,7 @@ value_t fl_string(value_t *args, u_int32_t nargs) size_t len, sz = 0; cvalue_t *temp; char *data; - wchar_t wc; + uint32_t wc; for(i=0; i < nargs; i++) { if (issymbol(args[i])) { @@ -114,7 +114,7 @@ value_t fl_string(value_t *args, u_int32_t nargs) continue; } else if (t == wcharsym) { - wc = *(wchar_t*)cv_data(temp); + wc = *(uint32_t*)cv_data(temp); sz += u8_charlen(wc); continue; } @@ -140,7 +140,7 @@ value_t fl_string(value_t *args, u_int32_t nargs) *ptr++ = *(char*)data; } else if (t == wcharsym) { - ptr += u8_wc_toutf8(ptr, *(wchar_t*)data); + ptr += u8_wc_toutf8(ptr, *(uint32_t*)data); } else { len = cv_len(temp); diff --git a/femtolisp/todo b/femtolisp/todo index f2b1db1..a28e22a 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -580,7 +580,7 @@ just a convenient coincidence that lets you do e.g. (int32 0) cvalues todo: -- use uint32_t instead of wchar_t in C code +* use uint32_t instead of wchar_t in C code - make sure empty arrays and 0-byte types really work * allow int constructors to accept other int cvalues * array constructor should accept any cvalue of the right size @@ -910,3 +910,14 @@ switch to miser mode, otherwise default is ok, for example: - if indent gets too large, dedent back to left edge ----------------------------------------------------------------------------- + +consolidated todo list as of 8/30: +- implement support for defining new opaque values +- finalizers in gc +- expose io stream object +- hashtable +- enable print-shared for cvalues' types +- remaining c types +- remaining cvalues functions +- special efficient reader for #array +- finish ios