Fix aliasing problem with sub-record predicates.

Add test to check that it works.

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 90bb68a46b8c6e9cb20ce0a12378bd723d92b2e2..7a3e9e02f55717bc1f979e6d340ae6db91283efc 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -109,16 +109,36 @@ USA.
 
     (letrec*
        ((predicate
-         (if parent-type
-             (lambda (object)
-               (and (%record? object)
-                    (fix:>= (%record-length object) end-index)
-                    (eq? (%record-type-instance-marker type)
-                         (%record-ref object start-index))))
-             (lambda (object)
-               (and (%record? object)
-                    (eq? (%record-type-instance-marker type)
-                         (%record-ref object 0))))))
+         (case (count-ancestors parent-type)
+           ((0)
+            (lambda (object)
+              (and (%record? object)
+                   (check-marker type object 0))))
+           ((1)
+            (lambda (object)
+              (and (%record? object)
+                   (fix:>= (%record-length object) end-index)
+                   (check-marker type object start-index)
+                   (check-marker parent-type object 0))))
+           ((2)
+            (let ((parent-start (%record-type-start-index parent-type))
+                  (grandparent-type (%record-type-parent parent-type)))
+              (lambda (object)
+                (and (%record? object)
+                     (fix:>= (%record-length object) end-index)
+                     (check-marker type object start-index)
+                     (check-marker parent-type object parent-start)
+                     (check-marker grandparent-type object 0)))))
+           (else
+            (lambda (object)
+              (and (%record? object)
+                   (fix:>= (%record-length object) end-index)
+                   (check-marker type object start-index)
+                   (let loop ((t parent-type))
+                     (and (check-marker t object (%record-type-start-index t))
+                          (if (%record-type-parent t)
+                              (loop (%record-type-parent t))
+                              #t))))))))
         (type
          (%%make-record-type type-name
                              predicate
@@ -135,6 +155,16 @@ USA.
                            (record-predicate parent-type)
                            record?))
       type)))
+\f
+(define (count-ancestors parent-type)
+  (let loop ((type parent-type) (n 0))
+    (if type
+       (loop (%record-type-parent type) (+ n 1))
+       n)))
+
+(define-integrable (check-marker type object index)
+  (eq? (%record-type-instance-marker type)
+       (%record-ref object index)))
 
 (define (generate-fields-by-name fields-by-index)
   (let loop ((fields (reverse (vector->list fields-by-index))) (filtered '()))

diff --git a/tests/runtime/test-record.scm b/tests/runtime/test-record.scm
index 4e3d050de4b4af9ba2cf91f7b1d6c573c6093885..2c21480861936c8a3c2930093250d6db18fcefb1 100644 (file)
--- a/tests/runtime/test-record.scm
+++ b/tests/runtime/test-record.scm
@@ -95,4 +95,19 @@ USA.
       (assert-eqv (t2-c t2) 5)
       (assert-eqv (t2-a t2) 2)
       (assert-eqv (record-type-descriptor t2) <t2>)
-      (assert-equal (pp-description t2) '((a #f) (b 3) (c 5) (a 2))))))
\ No newline at end of file
+      (assert-equal (pp-description t2) '((a #f) (b 3) (c 5) (a 2))))))
+
+(define-record-type (<t3> <t2>) make-t3 t3? (d t3-d))
+(define-record-type (<t4> <t1>) make-t4 t4? (w t3-w) (x t3-x) (y t3-y) (z t3-z))
+
+(define-test 'sub-record-predicates
+  (lambda ()
+    (let ((t3 (make-t3 2 3 5 7 11)))
+      (assert-true (t1? t3))
+      (assert-true (t2? t3))
+      (assert-true (t3? t3)))
+    (let ((t4 (make-t4 2 3 5 7 <t3> 11)))
+      (assert-true (t1? t4))
+      (assert-false (t2? t4))
+      (assert-false (t3? t4))
+      (assert-true (t4? t4)))))
\ No newline at end of file