Comparison with equal

lisp/kernel.gl

@@ -23,4 +23,8 @@
   (princ datum print-char-fun)
   (funcall (or print-char-fun 'write-byte) ?\n))
 
-(princln (= 1.0 1))
+(let ((t1 (make-hash-table))
+      (t2 (make-hash-table)))
+  (puthash t1 'a 'b)
+  (puthash t2 'a 'b)
+  (princln (equal t1 t2)))

src/base.c

@@ -75,8 +75,7 @@ DEFCONST(most_negative_fixnum, "most-negative-fixnum", "",
          MAKE_FIXNUM(MOST_NEGATIVE_FIXNUM));
 
 DEFUN(id, "id", (LispVal * obj), "(id)", "") {
-    // TODO not all values are handled here
-    return MAKE_FIXNUM((uintptr_t) obj);
+    return make_number_unsigned((uintptr_t) obj);
 }
 
 DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
@@ -97,6 +96,76 @@ DEFSPECIAL(function, "function", (LispVal * form), "(form)", "") {
     return form;
 }
 
+static LispVal *lists_equal(LispVal *l1, LispVal *l2) {
+    while (CONSP(l1) && CONSP(l2)) {
+        if (NILP(Fequal(XCAR(l1), XCAR(l2)))) {
+            return Qnil;
+        }
+        l1 = XCDR(l1);
+        l2 = XCDR(l2);
+    }
+    return Fequal(l1, l2);
+}
+
+static LispVal *hash_tables_equal(LispVal *obj1, LispVal *obj2) {
+    LispHashTable *t1 = obj1;
+    LispHashTable *t2 = obj2;
+    if (t1->count != t2->count) {
+        return Qnil;
+    }
+    HT_FOREACH_INDEX(t1, i) {
+        LispVal *v1 = HASH_VALUE(t1, i);
+        LispVal *v2 = Fgethash(t2, HASH_KEY(t1, i), Qunbound);
+        if (NILP(Fequal(v1, v2))) {
+            return Qnil;
+        }
+    }
+    return Qt;
+}
+
+DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)", "") {
+    if (EQ(obj1, obj2)) {
+        return Qt;
+    } else if (TYPE_OF(obj1) != TYPE_OF(obj2)) {
+        return Qnil;
+    }
+    switch (TYPE_OF(obj1)) {
+    case TYPE_SYMBOL:
+    case TYPE_FUNCTION:
+        // handled above
+        return Qnil;
+    case TYPE_HASH_TABLE:
+        return hash_tables_equal(obj1, obj2);
+    case TYPE_FIXNUM:
+        return XFIXNUM(obj1) == XFIXNUM(obj2) ? Qt : Qnil;
+    case TYPE_FLOAT:
+        return XLISP_FLOAT(obj1) == XLISP_FLOAT(obj2) ? Qt : Qnil;
+    case TYPE_STRING:
+        return Fstrings_equal(obj1, obj2);
+    case TYPE_CONS:
+        return lists_equal(obj1, obj2);
+    case TYPE_VECTOR: {
+        LispVector *v1 = obj1;
+        LispVector *v2 = obj2;
+        if (v1->length != v2->length) {
+            return Qnil;
+        }
+        for (size_t i = 0; i < v1->length; ++i) {
+            if (NILP(Fequal(v1->data[i], v2->data[i]))) {
+                return Qnil;
+            }
+        }
+        return Qt;
+    }
+    case TYPE_GMP:
+        return mpz_cmp(((LispGmp *) obj1)->val, ((LispGmp *) obj2)->val) == 0
+                   ? Qt
+                   : Qnil;
+    default:
+        abort();
+    }
+}
+
 // ################
 // # Constructors #
 // ################

src/base.h

@@ -373,6 +373,8 @@ DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
 DECLARE_FUNCTION(quote, (LispVal * form));
 DECLARE_FUNCTION(function, (LispVal * form));
 
+DECLARE_FUNCTION(equal, (LispVal * obj1, LispVal *obj2));
+
 // TODO probably move these to another file
 LispVal *make_vector(LispVal **data, size_t length, bool take);
 DECLARE_FUNCTION(vector, (LispVal * data));

src/hashtable.c

@@ -36,7 +36,7 @@ DEFUN(hash_table_p, "hash-table-p", (LispVal * val), "(val)", "") {
 }
 
 DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn),
-      "(hash-fn eq-fn)", "") {
+      "(&optional hash-fn eq-fn)", "") {
     LispHashTable *obj =
         lisp_alloc_object(sizeof(LispHashTable), TYPE_HASH_TABLE);
     obj->eq_fn = eq_fn;
@@ -56,8 +56,12 @@ static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) {
         return XFIXNUM(Fhash_string(key));
     } else {
         LispVal *hash = CALL(ht->hash_fn, key);
-        CHECK_TYPE(hash, TYPE_FIXNUM);
-        return XFIXNUM(hash);
+        if (LISP_GMP_P(hash)) {
+            return mpz_get_ui(((LispGmp *) hash)->val);
+        } else if (FIXNUMP(hash)) {
+            return XFIXNUM(hash);
+        }
+        signal_type_error(hash, Qinteger);
     }
 }