Handle circularity in arguments to equal?.

This is accomplished by detecting a pair of args that's been seen before and
returning the value from those args, or #t if there's no value yet.  Using a
true value allows the comparison to continue without committing to a particular
value for those args.  The actual value is determined when the original call
with those args finishes.

diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index b535c25f69575797eb1275bf0332102c998b9428..1638e39e83157ee1cbd20ae72833ae5c98491428 100644 (file)
--- a/src/runtime/equals.scm
+++ b/src/runtime/equals.scm
@@ -43,47 +43,39 @@ USA.
           (number:eqv? x y))))
 
 (define (equal? x y)
-  (or (eq? x y)
-      (cond ((pair? x)
-            (and (pair? y)
-                 (equal? (car x) (car y))
-                 (equal? (cdr x) (cdr y))))
-           ((vector? x)
-            (and (vector? y)
-                 (let ((size (vector-length x)))
-                   (and (fix:= size (vector-length y))
-                        (let loop ((index 0))
-                          (or (fix:= index size)
-                              (and (equal? (vector-ref x index)
+
+  (define (recur x y)
+    (or (eq? x y)
+       (detect-circ x y)))
+
+  (define detect-circ
+    (make-detect-circ
+     (lambda (x y)
+       (cond ((pair? x)
+             (and (pair? y)
+                  (recur (car x) (car y))
+                  (recur (cdr x) (cdr y))))
+            ((vector? x)
+             (and (vector? y)
+                  (let ((size (vector-length x)))
+                    (and (fix:= size (vector-length y))
+                         (let loop ((index 0))
+                           (or (fix:= index size)
+                               (and (recur (vector-ref x index)
                                            (vector-ref y index))
-                                   (loop (fix:+ index 1)))))))))
-           ((number? x)
-            (and (number? y)
-                 (number:eqv? x y)))
-           ((bytevector? x)
-            (and (bytevector? y)
-                 (bytevector=? x y)))
-           ((string? x)
-            (and (string? y)
-                 (string=? x y)))
-           ((weak-pair? x)
-            (and (weak-pair? y)
-                 (equal? (weak-car x) (weak-car y))
-                 (equal? (weak-cdr x) (weak-cdr y))))
-           ((cell? x)
-            (and (cell? y)
-                 (equal? (cell-contents x)
+                                    (loop (fix:+ index 1)))))))))
+            ((weak-pair? x)
+             (and (weak-pair? y)
+                  (recur (weak-car x) (weak-car y))
+                  (recur (weak-cdr x) (weak-cdr y))))
+            ((cell? x)
+             (and (cell? y)
+                  (recur (cell-contents x)
                          (cell-contents y))))
-           ((bit-string? x)
-            (and (bit-string? y)
-                 (bit-string=? x y)))
-           ((pathname? x)
-            (and (pathname? y)
-                 (pathname=? x y)))
-           ((char-set? x)
-            (and (char-set? y)
-                 (char-set= x y)))
-           (else #f))))
+            (else
+             (equal?-helper x y))))))
+
+  (recur x y))
 
 (define (equal-hash key)
   (cond ((primitive-object-hash key))
@@ -91,4 +83,53 @@ USA.
        ((pathname? key) (string-hash (->namestring key)))
        ((bit-string? key)
         (primitive-object-hash (bit-string->unsigned-integer key)))
-       (else (eq-hash key))))
\ No newline at end of file
+       (else (eq-hash key))))
+\f
+(define (make-detect-circ continue)
+  continue)
+
+(define ((make-mdc ht-type) continue)
+  (let ((ht (make-hash-table ht-type)))
+    (lambda (x y)
+      (let ((key (cons x y)))
+       (hash-table-ref ht key
+                       (lambda ()
+                         (hash-table-set! ht key #t)
+                         (let ((v (continue x y)))
+                           (hash-table-set! ht key v)
+                           v))
+                       (lambda (v) v))))))
+
+;;; This file gets loaded before the boot-dependency code, so defer registration
+;;; until it's available.
+(define (initialize-package!)
+  (add-boot-deps! '(runtime comparator)
+                 '(runtime hash-table))
+  (add-boot-init!
+   (lambda ()
+     (set! make-detect-circ
+          (make-mdc
+           (comparator->hash-table-type
+            (make-pair-comparator eq-comparator eq-comparator))))
+     unspecific)))
+
+(define (equal?-helper x y)
+  (cond ((number? x)
+        (and (number? y)
+             (number:eqv? x y)))
+       ((bytevector? x)
+        (and (bytevector? y)
+             (bytevector=? x y)))
+       ((string? x)
+        (and (string? y)
+             (string=? x y)))
+       ((bit-string? x)
+        (and (bit-string? y)
+             (bit-string=? x y)))
+       ((pathname? x)
+        (and (pathname? y)
+             (pathname=? x y)))
+       ((char-set? x)
+        (and (char-set? y)
+             (char-set= x y)))
+       (else #f)))
\ No newline at end of file

diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index b3d64d89e85e34160e82362d5de5b598c019e619..48642bada95feb648019dfab8de590b6b6f61043 100644 (file)
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -413,6 +413,12 @@ USA.
        (lambda ()
          (eval file-object (package/environment package))))))
 
+  (let ((package (find-package '(runtime equality))))
+    (with-current-package package
+      (lambda ()
+       ((lexical-reference (package/environment package)
+                           'initialize-package!)))))
+
   (load-files-with-boot-inits files1)
   (call-pkg-init-proc '(runtime gc-daemons) 'initialize-package!)
   (call-pkg-init-proc '(runtime garbage-collector) 'initialize-package!)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 43dab91eb9fc242a3ed7d065fb3b09f6cc4a2263..7a9b21e976e1394d23aa87e517430ad2d54be868 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2913,7 +2913,9 @@ USA.
          make-strong-eq-hash-table
          make-strong-eqv-hash-table
          set-hash-table-rehash-size!
-         set-hash-table-rehash-threshold!))
+         set-hash-table-rehash-threshold!)
+  (export (runtime equality)
+         comparator->hash-table-type))
 
 (define-package (runtime memoizer)
   (files "memoizer")

diff --git a/tests/check.scm b/tests/check.scm
index a73f61ce05a376dcea9bd879abce8cd53c665ad9..40b7a183b65e292e545372c66455aa0cd5ac96d8 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -79,6 +79,7 @@ USA.
     "runtime/test-dynamic-env"
     "runtime/test-entity"
     "runtime/test-ephemeron"
+    ("runtime/test-equals" inline)
     ("runtime/test-file-attributes" (runtime))
     "runtime/test-floenv"
     "runtime/test-flonum"

diff --git a/tests/runtime/test-equals.scm b/tests/runtime/test-equals.scm
new file mode 100644 (file)
index 0000000..f29a8e9
--- /dev/null
+++ b/tests/runtime/test-equals.scm
@@ -0,0 +1,64 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019, 2020, 2021, 2022 Massachusetts Institute of
+    Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(import (scheme base))
+
+(equal? '#1=(a b . #1#) '#2=(a b a b . #2#))
+'expect-true
+
+(equal? '#1=(a b . #1#) '#2=(a b a c . #2#))
+'expect-false
+
+(equal? '#1=(a b . #1#) '#2=(a b a . #2#))
+'expect-false
+
+(equal? '#1=(a b . #1#) '(a b . #1#))
+'expect-true
+
+(equal? '#1=(a b #1# c) '#2=(a b a b . #2#))
+'expect-false
+
+(equal? '#1=(a b #1# c) '#2=(a b #2# c))
+'expect-true
+
+(equal? '#1=#(a b #1# c) '#2=#(a b #2# c))
+'expect-true
+
+(equal? '#1=#(a b #1#) '#2=#(a b #2# c))
+'expect-false
+
+(equal? '#1=(a b (d #1# e) c) '#2=(a b (d #2# e) c))
+'expect-true
+
+(equal? '#1=(a b (#1# d e) c) '#2=(a b (#2# d e) c))
+'expect-true
+
+(equal? '#1=(#1# a) '#2=(#2# a))
+'expect-true
+
+(equal? '#1=(#1# a) '#2=(#2# b))
+'expect-false
\ No newline at end of file