- fixed equal? to terminate on all inputs as mandated by R6RS.

(thanks to Michael Adams and Kent Dybvig for making the code
   available in its entirety in their ICFP 2008 paper)

scheme/Makefile.am

@@ -28,7 +28,7 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss ikarus.pointers.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
  
 all: $(nodist_pkglib_DATA)
 

scheme/Makefile.in

@@ -183,7 +183,7 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
   ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
   ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss \
-  ikarus.reader.annotated.ss ikarus.pointers.ss
+  ikarus.reader.annotated.ss ikarus.pointers.ss ikarus.equal.ss
 
 revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
 sizeofvoidp = $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g")

scheme/ikarus.equal.ss

@@ -0,0 +1,166 @@
+
+
+;;; Copied from
+;;; Efficient Nondestructive Equality Checking for Trees and Graphs 
+;;; Michael D. Adams and R. Kent Dybvig 
+;;; ICFP 2008
+
+(library (ikarus.equal)
+  (export equal?)
+  (import (except (ikarus) equal?))
+
+  (module UNSAFE 
+    (< <= > >= = + - vector-ref vector-length car cdr)
+    (import 
+      (rename (ikarus system $vectors)
+        ($vector-length vector-length)
+        ($vector-ref    vector-ref))
+      (rename (ikarus system $pairs)
+        ($car   car)
+        ($cdr   cdr)) 
+      (rename (ikarus system $fx)
+        ($fx+      +)
+        ($fx-      -)
+        ($fx<      <)
+        ($fx>      >)
+        ($fx>=     >=)
+        ($fx<=     <=)
+        ($fx=      =))))
+
+
+
+  (define eq-hashtable-ref hashtable-ref)
+  (define eq-hashtable-set! hashtable-set!)
+
+  (define-struct box (content))
+
+  (define (union-find ht x y)
+    (import UNSAFE)
+    (define (find b)
+      (let ([n (box-content b)])
+        (if (box? n)
+            (let loop ([b b] [n n])
+              (let ([nn (box-content n)])
+                (if (box? nn) (begin (set-box-content! b nn) (loop n nn)) n)))
+            b)))
+    (let ([bx (eq-hashtable-ref ht x #f)]
+          [by (eq-hashtable-ref ht y #f)])
+      (if (not bx)
+          (if (not by)
+              (let ([b (make-box 1)])
+                (eq-hashtable-set! ht x b)
+                (eq-hashtable-set! ht y b)
+                #f)
+              (let ([ry (find by)]) (eq-hashtable-set! ht x ry) #f))
+          (if (not by)
+              (let ([rx (find bx)]) (eq-hashtable-set! ht y rx) #f)
+              (let ([rx (find bx)] [ry (find by)])
+                (or (eq? rx ry)
+                    (let ([nx (box-content rx)] [ny (box-content ry)])
+                      (if (> nx ny)
+                          (begin 
+                            (set-box-content! ry rx) 
+                            (set-box-content! rx (+ nx ny))
+                            #f)
+                          (begin
+                            (set-box-content! rx ry)
+                            (set-box-content! ry (+ ny nx))
+                            #f)))))))))
+
+  (define (pre? x y k)
+    (import UNSAFE)
+    (cond
+      [(eq? x y) k]
+      [(pair? x)
+       (and (pair? y)
+            (if (<= k 0)
+                k
+                (let ([k (pre? (car x) (car y) (- k 1))])
+                  (and k (pre? (cdr x) (cdr y) k)))))]
+      [(vector? x)
+       (and (vector? y)
+            (let ([n (vector-length x)])
+              (and (= (vector-length y) n)
+                   (let f ([i 0] [k k])
+                     (if (or (= i n) (<= k 0))
+                         k
+                         (let ([k (pre?
+                                    (vector-ref x i)
+                                    (vector-ref y i)
+                                    (- k 1))])
+                           (and k (f (+ i 1) k))))))))]
+      [(string? x) (and (string? y) (string=? x y) k)]
+      [else (and (eqv? x y) k)]))
+
+  (define (interleave? x y k)
+    (import UNSAFE)
+    (let ([ht #f])
+      (define (call-union-find x y)
+        (unless ht (set! ht (make-eq-hashtable)))
+        (union-find ht x y))
+      (define (e? x y k)
+        (if (<= k 0)
+            (if (= k kb) (fast? x y (random (* 2 k0))) (slow? x y k))
+            (fast? x y k)))
+      (define (slow? x y k)
+        (cond
+          [(eq? x y) k]
+          [(pair? x)
+           (and (pair? y)
+                (if (call-union-find x y)
+                    0
+                    (let ([k (e? (car x) (car y) (- k 1))])
+                      (and k (e? (cdr x) (cdr y) k)))))]
+          [(vector? x)
+           (and (vector? y)
+                (let ([n (vector-length x)])
+                  (and (= (vector-length y) n)
+                       (if (call-union-find x y)
+                           0
+                           (let f ([i 0] [k (- k 1)])
+                             (if (= i n)
+                                 k
+                                 (let ([k (e? (vector-ref x i)
+                                              (vector-ref y i)
+                                              k)])
+                                   (and k (f (+ i 1) k)))))))))]
+          [(string? x) (and (string? y) (string=? x y) k)]
+          [else (and (eqv? x y) k)]))
+      (define (fast? x y k)
+        (let ([k (- k 1)])
+          (cond
+            [(eq? x y) k]
+            [(pair? x)
+             (and (pair? y)
+                  (let ([k (e? (car x) (car y) k)])
+                    (and k (e? (cdr x) (cdr y) k))))]
+            [(vector? x)
+             (and (vector? y)
+                  (let ([n (vector-length x)])
+                    (and (= (vector-length y) n)
+                         (let f ([i 0] [k k])
+                           (if (= i n)
+                               k
+                               (let ([k (e? (vector-ref x i)
+                                            (vector-ref y i)
+                                            k)])
+                                 (and k (f (+ i 1) k))))))))]
+            [(string? x) (and (string? y) (string=? x y) k)]
+            [else (and (eqv? x y) k)])))
+      (and (e? x y k) #t)))
+
+  (define k0 400)
+  
+  (define kb -40)
+  
+  (define (interleave-equal? x y)
+    (interleave? x y k0))
+  
+  (define (precheck/interleave-equal? x y)
+    (let ([k (pre? x y k0)])
+      (and k (or (> k 0) (interleave? x y 0)))))
+
+  (define (equal? x y)
+    (precheck/interleave-equal? x y))
+
+  )

scheme/ikarus.predicates.ss

@@ -20,7 +20,7 @@
           number? complex? real? rational?
           integer? exact? inexact? eof-object? bwp-object? immediate?
           boolean? char? vector? bytevector? string? procedure? null? pair?
-          symbol? code? not weak-pair? eq? eqv? equal? boolean=?
+          symbol? code? not weak-pair? eq? eqv? boolean=?
           symbol=? finite? infinite? nan? real-valued?
           rational-valued? integer-valued? transcoder?)
   (import 
@@ -28,7 +28,7 @@
             number? complex? real?
             rational? integer? exact? inexact? eof-object? bwp-object?
             immediate? boolean? char? vector? bytevector? string? procedure?
-            null? pair? weak-pair? symbol? code? not eq? eqv? equal?
+            null? pair? weak-pair? symbol? code? not eq? eqv? 
             transcoder? boolean=? symbol=?
             finite? infinite? nan? real-valued? rational-valued? 
             integer-valued?)
@@ -313,39 +313,6 @@
   (define-pred symbol=? sys:symbol? "not a symbol")
   (define-pred boolean=? sys:boolean? "not a boolean")
 
-  (module (equal?)
-    (define vector-loop
-      (lambda (x y i n)
-        (or ($fx= i n)
-            (and (equal? ($vector-ref x i) ($vector-ref y i))
-                 (vector-loop x y ($fxadd1 i) n)))))
-    (define string-loop
-      (lambda (x y i n)
-        (or ($fx= i n)
-            (and ($char= ($string-ref x i) ($string-ref y i))
-                 (string-loop x y ($fxadd1 i) n)))))
-    (define equal?
-      (lambda (x y)
-        (cond
-          [(sys:eq? x y) #t]
-          [(pair? x) 
-           (and (pair? y)
-                (equal? ($car x) ($car y))
-                (equal? ($cdr x) ($cdr y)))]
-          [(vector? x)
-           (and (vector? y)
-                (let ([n ($vector-length x)])
-                  (and ($fx= n ($vector-length y))
-                       (vector-loop x y 0 n))))]
-          [(string? x)
-           (and (string? y)
-                (let ([n ($string-length x)])
-                  (and ($fx= n ($string-length y))
-                       (string-loop x y 0 n))))]
-          [(sys:bytevector? x)
-           (and (sys:bytevector? y) (bytevector=? x y))]
-          [(number? x) (eqv? x y)]
-          [else #f]))))
 
 
   )

scheme/last-revision

@@ -1 +1 @@
-1665
+1666

scheme/makefile.ss

@@ -58,6 +58,7 @@
     "ikarus.collect.ss"
     "ikarus.apply.ss"
     "ikarus.predicates.ss"
+    "ikarus.equal.ss"
     "ikarus.pairs.ss"
     "ikarus.lists.ss"
     "ikarus.fixnums.ss"