From 5ca1b441a6766eb7a64c169f84b77b4689bd701f Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 21 Mar 2018 01:50:54 -0700 Subject: [PATCH] Make record inheritance comply with SRFI 131. --- src/runtime/mit-macros.scm | 1 + src/runtime/record.scm | 22 ++++++++++------------ 2 files changed, 11 insertions(+), 12 deletions(-) diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index bf900b940..897416b12 100644 --- 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 131149771..9f3b111e7 100644 --- 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) -- 2.25.1