fixed some small flaws in (compare)

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.

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

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)
+    if (guess == NIL) {
-        return guess;
+        guess = cyc_compare(a, b, &equal_eq_hashtable);
-
+        ptrhash_reset(&equal_eq_hashtable, 512);
-    ptrhash_new(&h, 512);
+    }
-    guess = cyc_compare(a, b, &h);
-    ptrhash_free(&h);
     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
+  * preallocate hash table and call reset() instead of new/free
-  - specialized version for equal (unordered comparison)
   * less redundant tag checking, 3-bit tags
 */

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

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

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

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