core: Add equal2?.
authorJan Nieuwenhuizen <janneke@gnu.org>
Thu, 5 Apr 2018 18:01:04 +0000 (20:01 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Thu, 5 Apr 2018 18:01:04 +0000 (20:01 +0200)
* src/lib.c (equal2_p): New function.
* module/mes/base.mes (equal2?): Remove.

module/mes/base.mes
src/lib.c

index f3df2169cf01bf7645c452ca00fb32640bf76f26..789351b1c798bec7f04285c343215d06bf457e96 100644 (file)
 (define (and=> value procedure) (and value (procedure value)))
 (define eqv? eq?)
 
-(define (equal2? a b)
-  (if (and (null? a) (null? b)) #t
-      (if (and (pair? a) (pair? b))
-          (and (equal2? (car a) (car b))
-               (equal2? (cdr a) (cdr b)))
-          (if (and (string? a) (string? b))
-              (eq? (string->symbol a) (string->symbol b))
-              (if (and (vector? a) (vector? b))
-                  (equal2? (vector->list a) (vector->list b))
-                  (eq? a b))))))
-
 (define (equal? . x)
   (if (or (null? x) (null? (cdr x))) #t
       (if (null? (cddr x)) (equal2? (car x) (cadr x))
index f660b8f61d4714df919475b3691724752cc23a40..5c03111c6c8c2887ea0cd319794b24b965d13332 100644 (file)
--- a/src/lib.c
+++ b/src/lib.c
@@ -268,3 +268,33 @@ memq (SCM x, SCM a)
   return a != cell_nil ? a : cell_f;
 }
 
+SCM
+equal2_p (SCM a, SCM b)
+{
+  if (a == cell_nil && b == cell_nil)
+    return cell_t;
+  if (TYPE (a) == TPAIR && TYPE (b) == TPAIR)
+    return equal2_p (CAR (a), CAR (b)) == cell_t
+      && equal2_p (CDR (a), CDR (b)) == cell_t
+      ? cell_t : cell_f;
+  if (TYPE (a) == TSTRING && TYPE (b) == TSTRING)
+    return equal2_p (STRING (a), STRING (b));
+  if (TYPE (a) == TVECTOR && TYPE (b) == TVECTOR)
+    {
+      if (LENGTH (a) != LENGTH (b))
+        return cell_f;
+      for (int i=0; i < LENGTH (a); i++)
+        {
+          SCM ai = VECTOR (a) + i;
+          SCM bi = VECTOR (b) + i;
+          if (TYPE (ai) == TREF)
+            ai = REF (ai);
+          if (TYPE (bi) == TREF)
+            bi = REF (bi);
+          if (equal2_p (ai, bi) == cell_f)
+            return cell_f;
+        }
+      return cell_t;
+    }
+  return eq_p (a, b);
+}