Ticket #1293: srfi-69-testcases.patch

tests/hash-table-tests.scm

@@ -1 +1 @@
 ;;;; hash-table-tests.scm
 
-(require-extension srfi-69 data-structures extras)
+(require-extension srfi-69 data-structures extras lolevel)
 
 (print "SRFI 69 procedures")
 (assert (eq? hash equal?-hash))
@@ -240 +240 @@
       (recursive-hash-max-length dl)
       (print hsh1 " <?> " hsh2)
       (assert (not (= hsh1 hsh2))) ) ) )
+
+;; Regression test for #1293, found by John Croisant
+(print "HT - Retrieve compound objects after GC and mutate contents")
+(set! ht (make-hash-table eq? hash-by-identity))
+(let* ((lst (list 1 2 3))
+       (vec (vector 1 2 3))
+       (pvec (make-pointer-vector 5 (address->pointer 1)))
+       (loc (make-locative (cons 1 2)))
+       (str (string #\x #\y #\z))
+       (objects (list lst vec pvec loc str))
+       (hashes (map hash-by-identity objects)))
+
+  (for-each (lambda (obj) (hash-table-set! ht obj obj))
+            objects)
+
+;  (gc #t)
+
+  (for-each (lambda (obj)
+              (print "Exists? " obj)
+              (assert (hash-table-exists? ht obj)))
+            objects)
+
+  (for-each (lambda (obj hash)
+              (print "Same hash? " obj)
+              (assert (= (hash-by-identity obj) hash)))
+            objects hashes)
+
+  (print "After mutation")
+
+  (set-car! lst (string #\l #\s #\t))
+  (vector-set! vec 0 (string #\v #\e #\c))
+  (pointer-vector-set! pvec 0 (address->pointer 0))
+  (locative-set! loc (string #\h #\a #\i))
+  (string-set! str 0 #\f)
+
+  ;; In each case, the object is the same: only contents have changed
+  (for-each (lambda (obj)
+              (print "Exists? " obj)
+              (assert (hash-table-exists? ht obj)))
+            objects)
+
+  (for-each (lambda (obj hash)
+              (print "Same hash? " obj)
+              (assert (= (hash-by-identity obj) hash)))
+            objects hashes)
+
+  (gc #t)
+
+  (for-each (lambda (obj)
+              (print "Exists? " obj)
+              (assert (hash-table-exists? ht obj)))
+            objects)
+
+  (for-each (lambda (obj hash)
+              (print "Same hash? " obj)
+              (assert (= (hash-by-identity obj) hash)))
+            objects hashes))