From 01e3ca0ede25ee3a63dc4fbbba79a0f78b066659 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Sep 2019 13:41:39 -0700
Subject: [PATCH] Fix aliasing problem with sub-record predicates.

Add test to check that it works.
---
 src/runtime/record.scm        | 50 ++++++++++++++++++++++++++++-------
 tests/runtime/test-record.scm | 17 +++++++++++-
 2 files changed, 56 insertions(+), 11 deletions(-)

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 90bb68a46..7a3e9e02f 100644
--- 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)))
+
+(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 4e3d050de..2c2148086 100644
--- 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
-- 
2.25.1