ref: af8b332367752471d1321a096a9604ef467892a2
parent: ca1b12064ff8d177c5642645b25b13aa192dfdc4
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Aug 30 18:18:20 EDT 2008
fixed some small flaws in (compare)
--- /dev/null
+++ b/femtolisp/FLOSSING
@@ -1,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.
--- a/femtolisp/attic/trash.c
+++ b/femtolisp/attic/trash.c
@@ -127,3 +127,177 @@
}
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);
+}
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -30,8 +30,10 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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
*/
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -559,8 +559,6 @@
return POP();
}
-extern value_t compare(value_t a, value_t b);
-
int isnumber(value_t v)
{return (isfixnum(v) ||
@@ -900,7 +898,7 @@
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 @@
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 @@
// initialization -------------------------------------------------------------
extern void builtins_init();
+extern void comparehash_init();
void lisp_init(void)
{@@ -1314,6 +1313,7 @@
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);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -121,7 +121,8 @@
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);
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -99,7 +99,7 @@
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 @@
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 @@
*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);
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -580,7 +580,7 @@
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 @@
- 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