[Guile-commits] branch master updated: Optionally allow duplicate field names in core records

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new 86a9f9a  Optionally allow duplicate field names in core records
86a9f9a is described below

commit 86a9f9a27176968bbae46aceed114634ca7c693e
Author: Andy Wingo <address@hidden>
AuthorDate: Sun Jan 12 21:50:08 2020 +0100

    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 16ebc64..dbe0853 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 ede16de..a6b09c4 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 5d7df5e..23ba1da 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 9eb0934..e5a154c 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)))))