Make record inheritance comply with SRFI 131.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index bf900b940709214aa6801ac59963526a8ff84ece..897416b1230ebecadb700e287feda46a3e360721 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -114,6 +114,7 @@ USA.
 (define-feature 'srfi-39 always) ;Parameter objects
 (define-feature 'srfi-62 always) ;S-expression comments
 (define-feature 'srfi-69 always) ;Basic Hash Tables
+(define-feature 'srfi-131 always) ;ERR5RS Record Syntax (reduced)
 
 (define ((os? value))
   (eq? value microcode-id/operating-system))

diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index 131149771af77df4c4bd2ecc111d7b69fdebc2e1..9f3b111e7e380a82e873c2650d7ed185c32c45b2 100644 (file)
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -77,13 +77,10 @@ USA.
        (%make-record-type type-name field-specs #f)
        (begin
          (guarantee record-type? parent-type 'new-make-record-type)
-         (let ((field-specs
-                (append (record-type-field-specs parent-type)
-                        field-specs)))
-           (if (duplicate-fields? field-specs)
-               (error "Overlap between child and parent fields:"
-                      field-specs))
-           (%make-record-type type-name field-specs parent-type))))))
+         (%make-record-type type-name
+                            (append (record-type-field-specs parent-type)
+                                    field-specs)
+                            parent-type)))))
 
 (define (%make-record-type type-name field-specs parent-type)
   (letrec*
@@ -515,13 +512,14 @@ USA.
 (define record-updater record-modifier)
 
 (define (record-type-field-index record-type name error?)
-  (let* ((names (%record-type-field-names record-type))
-        (n (vector-length names)))
-    (let loop ((i 0))
-      (if (fix:< i n)
+  (let ((names (%record-type-field-names record-type)))
+    ;; Search from end because a child field must override an ancestor field of
+    ;; the same name.
+    (let loop ((i (fix:- (vector-length names) 1)))
+      (if (fix:>= i 0)
          (if (eq? (vector-ref names i) name)
              (fix:+ i 1)
-             (loop (fix:+ i 1)))
+             (loop (fix:- i 1)))
          (and error?
               (record-type-field-index record-type
                                        (error:no-such-slot record-type name)