From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 2 Oct 2018 06:13:38 +0000 (-0700)
Subject: Allow more general record predicates.
X-Git-Tag: mit-scheme-pucked-9.2.19~2^2~22
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=811678039b7c385d586d14acdaa70cc574b5782e;p=mit-scheme.git

Allow more general record predicates.

Rather than insisting on a linear inheritance of record types, the record
predicate now allows arbitrary sub-type relations.  This can of course cause
problems if misused, so use with care.
---

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 1ec917494..19d65980a 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -138,7 +138,7 @@ USA.
 			(%record-ref object 0))
 		   (let ((type* (%record->type object)))
 		     (and type*
-			  (%record-type< type* type)))))))
+			  (%record-type<= type* type)))))))
        (type
 	(%%make-record-type type-name
 			    predicate
@@ -160,11 +160,17 @@ USA.
 	  ((%record-type-proxy? marker) (%proxy->record-type marker))
 	  (else #f))))
 
-(define (%record-type< t1 t2)
-  (let ((parent (%record-type-parent t1)))
-    (and parent
-	 (or (eq? parent t2)
-	     (%record-type< parent t2)))))
+;; Temporary definition for cold load.
+(define (%record-type<= t1 t2)
+  (or (eq? t1 t2)
+      (let ((parent (%record-type-parent t1)))
+	(and parent
+	     (%record-type<= parent t2)))))
+
+(defer-boot-action 'predicate-relations
+  (lambda ()
+    (set! %record-type<= dispatch-tag<=)
+    unspecific))
 
 (define %record-metatag)
 (define record-type?)