-- vyzoIf there is a shared object in the structure (without recursion) it needs to be eq? to its counterpart.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:
(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))
_______________________________________________
Gambit-list mailing list
Gambit-list@iro.umontreal.ca
https://webmail.iro.umontreal.ca/mailman/listinfo/gambit- list