Implementation of equal? for recursive structures - Gambit-list

14 Sep 2017


      Marc,
Can we get an implementation of equal? that works for recursive structures
per r7rs?
It doesn't need to be called equal?, it can be called equal-shared? for
instance.
I have an initial implementation that works with shared structures, but
there is an edge case:
If there is a shared object in the structure (without recursion) it needs
to be eq? to its counterpart.
(def (r7rs-equal? obj1 obj2)
  (def ht (make-hash-table-eq))
(def (equal obj1 obj2)
    (cond
     ((##eq? obj1 obj2))
     ((immediate? obj1) #f)             ; should be eq?
     ((number? obj1)
      (##eqv? obj1 obj2))
     ((##table-ref ht obj1 #f)
      => (cut ##eq? <> obj2))         ; edge case mentioned above
     ((##pair? obj1)
      (and (##pair? obj2)
           (begin
             (##table-set! ht obj1 obj2)
             (and (equal (##car obj1) (##car obj2))
                  (equal (##cdr obj1) (##cdr obj2))))))
     ((##vector? obj1)
      (and (##vector? obj2)
           (let (len (##vector-length obj1))
             (and (##fx= len (##vector-length obj2))
                  (begin (##table-set! ht obj1 obj2)
                         (vector-equal obj1 obj2 0 len))))))
     ((##string? obj2)
      (and (##string? obj2)
           (##string-equal? obj1 obj2)))
     ((##u8vector? obj1)
      (and (##u8vector? obj2)
           (##u8vector-equal? obj1 obj2)))
     ((##s8vector? obj1)
      (and (##s8vector? obj2)
           (##s8vector-equal? obj1 obj2)))
     ((##u16vector? obj1)
      (and (##u16vector? obj2)
           (##u16vector-equal? obj1 obj2)))
     ((##s16vector? obj1)
      (and (##s16vector? obj2)
           (##s16vector-equal? obj1 obj2)))
     ((##u32vector? obj1)
      (and (##u32vector? obj2)
           (##u32vector-equal? obj1 obj2)))
     ((##s32vector? obj1)
      (and (##s32vector? obj2)
           (##s32vector-equal? obj1 obj2)))
     ((##u64vector? obj1)
      (and (##u64vector? obj2)
           (##u64vector-equal? obj1 obj2)))
     ((##s64vector? obj1)
      (and (##s64vector? obj2)
           (##s64vector-equal? obj1 obj2)))
     ((##f32vector? obj1)
      (and (##f32vector? obj2)
           (##f32vector-equal? obj1 obj2)))
     ((##f64vector? obj1)
      (and (##f64vector? obj2)
           (##f64vector-equal? obj1 obj2)))
     ((table? obj1)
      (and (table? obj2)
           (begin
             (##table-set! ht obj1 obj2)
             (table-equal obj1 obj2))))
     ((##structure? obj1)
      (and (##structure? obj2)
           (let* ((t1 (##structure-type obj1))
                  (t2 (##structure-type obj2))
                  (tid1 (##type-id t1))
                  (tid2 (##type-id t2)))
             (and (##eq? tid1 tid2)
                  (let (len (##vector-length obj1))
                    (and (##fx= len (##vector-length obj2))
                         (##fx= (##fxand (##type-flags t1) 1) 0) ; not
opaque
                         (begin
                           (##table-set! ht obj1 obj2)
                           (vector-equal obj1 obj2 1 len))))))))
     ((##box? obj1)
      (and (##box? obj2)
           (begin
             (##table-set! ht obj1 obj2)
             (equal (##unbox obj1) (##unbox obj2)))))
     (else #f)))
(def (vector-equal obj1 obj2 i len)
    (let lp ((i i))
      (if (##fx< i len)
        (and (equal (##vector-ref obj1 i) (##vector-ref obj2 i))
             (lp (##fx+ i 1)))
        #t)))
(def (table-equal obj1 obj2)
    (and (##fx= (##vector-ref obj1 1) ; flags
                (##vector-ref obj2 1))
         (##eq? (##vector-ref obj1 2) ; test
                (##vector-ref obj2 2))
         (##eq? (##vector-ref obj1 3) ; hash
                (##vector-ref obj2 3))
         (##fx= (##table-length obj1)
                (##table-length obj2))
         (not (##table-search
               (lambda (k1 v1)
                 (let (v2 (##table-ref obj2 k1 nil))
                   (not (equal v1 v2))))
               obj1))))
(equal obj1 obj2))
-- vyzo