From 86a9f9a27176968bbae46aceed114634ca7c693e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 12 Jan 2020 21:50:08 +0100 Subject: [PATCH] Optionally allow duplicate field names in core records * NEWS: Update. * doc/ref/api-data.texi (Records): Update docs. * module/ice-9/boot-9.scm (make-record-type): Add #:allow-duplicate-field-names? keyword argument. (record-accessor, record-modifier): Allow passing indexes to identify fields. * module/rnrs/records/procedural.scm (make-record-type-descriptor): Allow duplicate field names. Fixes #38611. --- NEWS | 7 +++++++ doc/ref/api-data.texi | 24 ++++++++++++++-------- module/ice-9/boot-9.scm | 32 +++++++++++++++++++++--------- module/rnrs/records/procedural.scm | 3 ++- 4 files changed, 48 insertions(+), 18 deletions(-) diff --git a/NEWS b/NEWS index 16ebc64a9..dbe0853ab 100644 --- a/NEWS +++ b/NEWS @@ -79,6 +79,13 @@ Somewhat embarrassingly, the R7RS support added earlier in 2.9 failed to include an implementation of `define-library'. This oversight has been corrected :) +** Optionally allow duplicate field names in core records + +See the new #:allow-duplicate-field-names? keyword argument to +`make-record-type' in the manual, for more. This restores a needed +feature to R6RS records. + + Changes in alpha 2.9.x (since the stable 2.2 series): diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index ede16de64..a6b09c478 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006-2017, 2019 +@c Copyright (C) 1996, 1997, 2000-2004, 2006-2017, 2019-2020 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8649,6 +8649,7 @@ promise that records are disjoint with other Scheme types. @deffn {Scheme Procedure} make-record-type type-name field-names [print] @ [#:parent=@code{#f}] [#:uid=@code{#f}] @ [#:extensible?=@code{#f}] [#:opaque?=@code{#f}] @ + [#:allow-duplicate-field-names?=@code{#t}] Create and return a new @dfn{record-type descriptor}. @var{type-name} is a string naming the type. Currently it's only used @@ -8656,7 +8657,8 @@ in the printed representation of records, and in diagnostics. @var{field-names} is a list of elements of the form @code{(immutable @var{name})}, @code{(mutable @var{name})}, or @var{name}, where @var{name} are symbols naming the fields of a record of the type. -Duplicates are not allowed among these symbols. +Duplicates are not allowed among these symbols, unless +@var{allow-duplicate-field-names?} is true. @example (make-record-type "employee" '(name age salary)) @@ -8723,9 +8725,16 @@ Return a procedure for reading the value of a particular field of a member of the type represented by @var{rtd}. The returned procedure accepts exactly one argument which must be a record of the appropriate type; it returns the current value of the field named by the symbol -@var{field-name} in that record. The symbol @var{field-name} must be a -member of the list of field-names in the call to @code{make-record-type} -that created the type represented by @var{rtd}. +@var{field-name} in that record. + +If @var{field-name} is a symbol, it must be a member of the list of +field-names in the call to @code{make-record-type} that created the type +represented by @var{rtd}. If multiple fields in @var{rtd} have the same +name, @code{record-accessor} returns the first one. + +If @var{field-name} is an integer, it should be an index into +@code{(record-type-fields @var{rtd})}. This allows accessing fields +with duplicate names. @end deffn @deffn {Scheme Procedure} record-modifier rtd field-name @@ -8735,9 +8744,8 @@ accepts exactly two arguments: first, a record of the appropriate type, and second, an arbitrary Scheme value; it modifies the field named by the symbol @var{field-name} in that record to contain the given value. The returned value of the modifier procedure is unspecified. The symbol -@var{field-name} must be a member of the list of field-names in the call -to @code{make-record-type} that created the type represented by -@var{rtd}. +@var{field-name} is a field name or a field index, as in +@code{record-modifier}. @end deffn @deffn {Scheme Procedure} record-type-descriptor record diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5d7df5edd..23ba1da4f 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -984,7 +984,7 @@ VALUE." (make-hash-table)) (define* (make-record-type type-name fields #:optional printer #:key - parent uid extensible? + parent uid extensible? allow-duplicate-field-names? (opaque? (and=> parent record-type-opaque?))) ;; Pre-generate constructors for nfields < 20. (define-syntax make-constructor @@ -1060,7 +1060,7 @@ VALUE." (fields (cdr fields))) (unless (symbol? field) (error "expected field to be a symbol" field)) - (when (memq field fields) + (when (and (not allow-duplicate-field-names?) (memq field fields)) (error "duplicate field" field)) (check-fields fields)))) @@ -1069,7 +1069,7 @@ VALUE." tail (let ((field (car head)) (tail (append-fields (cdr head) tail))) - (when (memq field tail) + (when (and (not allow-duplicate-field-names?) (memq field tail)) (error "duplicate field" field)) (cons field tail)))) @@ -1201,10 +1201,17 @@ VALUE." (eq? (vector-ref parents pos) rtd)))))))) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))) -(define (record-accessor rtd field-name) +(define (record-accessor rtd field-name-or-idx) + (define vtable-index-size 5) ; FIXME: pull from struct.h + (define (record-nfields rtd) + (struct-ref/unboxed rtd vtable-index-size)) (let ((type-name (record-type-name rtd)) - (pos (or (list-index (record-type-fields rtd) field-name) - (error 'no-such-field field-name))) + (pos (cond + ((and (exact-integer? field-name-or-idx) + (<= 0 field-name-or-idx (record-nfields rtd))) + field-name-or-idx) + ((list-index (record-type-fields rtd) field-name-or-idx)) + (else (error 'no-such-field field-name-or-idx)))) (pred (record-predicate rtd))) (lambda (obj) (unless (pred obj) @@ -1214,10 +1221,17 @@ VALUE." #f)) (struct-ref obj pos)))) -(define (record-modifier rtd field-name) +(define (record-modifier rtd field-name-or-idx) + (define vtable-index-size 5) ; FIXME: pull from struct.h + (define (record-nfields rtd) + (struct-ref/unboxed rtd vtable-index-size)) (let ((type-name (record-type-name rtd)) - (pos (or (list-index (record-type-fields rtd) field-name) - (error 'no-such-field field-name))) + (pos (cond + ((and (exact-integer? field-name-or-idx) + (<= 0 field-name-or-idx (record-nfields rtd))) + field-name-or-idx) + ((list-index (record-type-fields rtd) field-name-or-idx)) + (else (error 'no-such-field field-name-or-idx)))) (pred (record-predicate rtd))) (unless (logbit? pos (record-type-mutable-fields rtd)) (error "field is immutable" rtd field-name)) diff --git a/module/rnrs/records/procedural.scm b/module/rnrs/records/procedural.scm index 9eb0934eb..e5a154c29 100644 --- a/module/rnrs/records/procedural.scm +++ b/module/rnrs/records/procedural.scm @@ -1,6 +1,6 @@ ;;; procedural.scm --- Procedural interface to R6RS records -;; Copyright (C) 2010, 2017 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2017, 2019-2020 Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -53,6 +53,7 @@ (define (make-record-type-descriptor name parent uid sealed? opaque? fields) (make-record-type name (vector->list fields) #:parent parent #:uid uid #:extensible? (not sealed?) + #:allow-duplicate-field-names #t #:opaque? (or opaque? (and parent (record-type-opaque? parent)))))