equal-hash dealing with cycles

equal-hash.scm

(import 
  (ironscheme)
  (only (ironscheme core) eqv-hash))

(define (clobber a b)
  (+ (* a 33) b)) 

(define (vector-fold-left combine nil vec)
  (let ((len (vector-length vec)))
    (let f ((i 0)(nil nil))
      (if (fx=? i len)
          nil
          (f (fxadd1 i) 
             (combine nil (vector-ref vec i)))))))

(define (EQUAL-HASH obj)
  (define ht (make-eq-hashtable))
  (bitwise-and 
    #x7FFFFFFF
    (let hash ((obj obj))
      (cond
        [(or (null? obj) (hashtable-contains? ht obj)) 0]
        [else 
          (hashtable-set! ht obj obj)
          (cond
            [(string? obj)
              (string-hash obj)]
            [(pair? obj)
              (clobber 
                (hash (car obj))
                (hash (cdr obj)))]
            [(vector? obj)
              (vector-fold-left 
                (lambda (a v)
                  (clobber a (hash v)))
                100 obj)]
            [(bytevector? obj)
              (hash (list->vector (bytevector->u8-list obj)))]
            [(record? obj)
              (let p ((rtd (record-rtd obj))(h 200))
                (if (not rtd)
                    h
                    (let ((fc (vector-length (record-type-field-names rtd))))
                      (let f ((i 0)(h h))
                        (if (fx=? i fc)
                            (p (record-type-parent rtd) h)
                            (f (fxadd1 i)
                               (clobber
                                 h
                                 (hash ((record-accessor rtd i) obj)))))))))]
            [else 
              (eqv-hash obj)])]))))

(define cycle (list 'a 'b 'c))
(define cyc2 (list 'a 'b 'c))
(set-cdr! (cddr cycle) cycle)
(set-car! (cdr cyc2) cyc2)

(define cyc-vec (vector 1 2 3 4))
(vector-set! cyc-vec 2 cyc-vec)

(define-record-type kons (fields kar kdr))
(define-record-type okons (opaque #t) (fields kar kdr))
(define-record-type mkons (fields (mutable kar) (mutable kdr)))

(define r (make-kons 1 '()))
(define opr (make-okons 1 '()))
(define mr (make-mkons 2 (make-mkons 3 '())))
(mkons-kdr-set! (mkons-kdr mr) mr)

(define-record-type (point make-point point?)
  (fields (immutable x point-x)
          (mutable y point-y set-point-y!)))

(define-record-type (cpoint make-cpoint cpoint?)
  (parent point)
  (protocol
   (lambda (n)
     (lambda (x y c) 
       ((n x y) (color->rgb c)))))
  (fields
    (mutable rgb cpoint-rgb cpoint-rgb-set!)))

(define (color->rgb c)
  (cons 'rgb c))

(define p1 (make-point 1 2))
(define p2 (make-cpoint 3 4 'red))
(define p3 (make-cpoint 1 2 'red))
(define p4 (make-cpoint 1 2 'blue))

(define-record-type nil (fields))

(define-syntax TEST
  (syntax-rules ()
    [(_ obj)
      (begin       
        (write 'obj)
        (display " = ")
        (displayln (EQUAL-HASH obj)))]))

(TEST 'foo)
(TEST #f)
(TEST #t)
(TEST '())
(TEST 1)
(TEST #\a)
(TEST "")
(TEST "a")
(TEST "abc")
(TEST '(1))
(TEST '(1 2))
(TEST '(1 . 2))
(TEST '(a b))
(TEST '(a . b))
(TEST '#())
(TEST '#(a))
(TEST '#(a  b))
(TEST '#vu8())
(TEST '#vu8(1))
(TEST '#vu8(1 2))
(TEST cycle)
(TEST cyc2)
(TEST cyc-vec)
(TEST (make-kons 1 2))
(TEST r)
(TEST opr)
(TEST mr)
(TEST p1)
(TEST p2)
(TEST p3)
(TEST p4)
(TEST (make-nil))
(TEST (make-nil))