[Guile-commits] 07/07: Record accessors respect subtyping

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f060f1a4e69a21c6a95410f3cea0b7f957c3e2c0
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 22 15:05:14 2019 +0200

    Record accessors respect subtyping
    
    * module/ice-9/boot-9.scm (make-record-type): Don't allow subtyping of
      final types.
      (%record-type-error): Remove helper.
      (record-accessor, record-modifier): Use computed record type
      predicate, to allow for subtyping.
      (define-record-type): Adapt to %record-type-error going away; these
      types are final so no accessor adaptation is needed.
    * test-suite/tests/records.test: Add tests.
    * doc/ref/api-data.texi (Records): Update.
---
 doc/ref/api-data.texi         | 28 +++++++++++-------
 module/ice-9/boot-9.scm       | 69 +++++++++++++++++++++++++------------------
 test-suite/tests/records.test | 52 ++++++++++++++++++++++++++++++--
 3 files changed, 108 insertions(+), 41 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 5b9c565..9b6cd88 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8630,7 +8630,8 @@ Note that @code{record?} may be true of any Scheme value; 
there is no
 promise that records are disjoint with other Scheme types.
 @end deffn
 
-@deffn {Scheme Procedure} make-record-type type-name field-names [print]
+@deffn {Scheme Procedure} make-record-type type-name field-names [print] @
+       [#:final?=@code{#t}] [parent=@code{#f}]
 Create and return a new @dfn{record-type descriptor}.
 
 @var{type-name} is a string naming the type.  Currently it's only used
@@ -8646,19 +8647,24 @@ The optional @var{print} argument is a function used by
 @code{display}, @code{write}, etc, for printing a record of the new
 type.  It's called as @code{(@var{print} record port)} and should look
 at @var{record} and write to @var{port}.
+
+Pass the @code{#:parent} keyword to derive a record type from a
+supertype.  A derived record type has the fields from its parent type,
+followed by fields declared in the @code{make-record-type} call.  Record
+predicates and field accessors for instance of a parent type will also
+work on any instance of a subtype.
+
+@cindex final record types
+@cindex record types, final
+Allowing record subtyping has a small amount of overhead.  To avoid this
+overhead, declare the record type as @dfn{final} by passing
+@code{#:final? #t}.  Record types in Guile are final by default.
 @end deffn
 
-@deffn {Scheme Procedure} record-constructor rtd [field-names]
+@deffn {Scheme Procedure} record-constructor rtd
 Return a procedure for constructing new members of the type represented
-by @var{rtd}.  The returned procedure accepts exactly as many arguments
-as there are symbols in the given list, @var{field-names}; these are
-used, in order, as the initial values of those fields in a new record,
-which is returned by the constructor procedure.  The values of any
-fields not named in that list are unspecified.  The @var{field-names}
-argument defaults to the list of field names in the call to
-@code{make-record-type} that created the type represented by @var{rtd};
-if the @var{field-names} argument is provided, it is an error if it
-contains any duplicates or any symbols not in the default list.
+by @var{rtd}.  The result will be a procedure accepting exactly as many
+arguments as there are fields in the record type.
 @end deffn
 
 @deffn {Scheme Procedure} record-predicate rtd
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 24cecb0..0238381 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1285,6 +1285,8 @@ VALUE."
   (define parents
     (cond
      ((record-type? parent)
+      (when (memq 'final (record-type-flags parent))
+        (error "parent type is final"))
       (let* ((parent-parents (record-type-parents parent))
              (parent-nparents (vector-length parent-parents))
              (parents (make-vector (1+ parent-nparents))))
@@ -1362,36 +1364,37 @@ VALUE."
                        (and (< pos (vector-length parents))
                             (eq? (vector-ref parents pos) rtd))))))))))
 
-(define (%record-type-error rtd obj)  ;; private helper
-  (or (eq? rtd (record-type-descriptor obj))
-      (scm-error 'wrong-type-arg "%record-type-check"
-                 "Wrong type record (want `~S'): ~S"
-                 (list (record-type-name rtd) obj)
-                 #f)))
-
 (define (record-accessor rtd field-name)
-  (let ((pos (list-index (record-type-fields rtd) field-name)))
-    (if (not pos)
-        (error 'no-such-field field-name))
+  (let ((type-name (record-type-name rtd))
+        (pos (or (list-index (record-type-fields rtd) field-name)
+                 (error 'no-such-field field-name)))
+        (pred (record-predicate rtd)))
     (lambda (obj)
-      (if (eq? (struct-vtable obj) rtd)
-          (struct-ref obj pos)
-          (%record-type-error rtd obj)))))
+      (unless (pred obj)
+        (scm-error 'wrong-type-arg "record-accessor"
+                   "Wrong type argument (want `~S'): ~S"
+                   (list type-name obj)
+                   #f))
+      (struct-ref obj pos))))
 
 (define (record-modifier rtd field-name)
-  (let ((pos (list-index (record-type-fields rtd) field-name)))
-    (if (not pos)
-        (error 'no-such-field field-name))
+  (let ((type-name (record-type-name rtd))
+        (pos (or (list-index (record-type-fields rtd) field-name)
+                 (error 'no-such-field field-name)))
+        (pred (record-predicate rtd)))
     (lambda (obj val)
-      (if (eq? (struct-vtable obj) rtd)
-          (struct-set! obj pos val)
-          (%record-type-error rtd obj)))))
+      (unless (pred obj)
+        (scm-error 'wrong-type-arg "record-modifier"
+                   "Wrong type argument (want `~S'): ~S"
+                   (list type-name obj)
+                   #f))
+      (struct-set! obj pos val))))
 
 (define (record? obj)
   (and (struct? obj) (record-type? (struct-vtable obj))))
 
 (define (record-type-descriptor obj)
-  (if (struct? obj)
+  (if (record? obj)
       (struct-vtable obj)
       (error 'not-a-record obj)))
 
@@ -1938,20 +1941,30 @@ name extensions listed in %load-extensions."
                                       fragments))))
          
          (define (getter rtd type-name field slot)
-           #`(define #,(make-id rtd type-name '- field)
+           (define id (make-id rtd type-name '- field))
+           #`(define #,id
                (let ((rtd #,rtd))
                  (lambda (#,type-name)
-                   (if (eq? (struct-vtable #,type-name) rtd)
-                       (struct-ref #,type-name #,slot)
-                       (%record-type-error rtd #,type-name))))))
+                   (unless (eq? (struct-vtable #,type-name) rtd)
+                     (scm-error 'wrong-type-arg
+                                #,(symbol->string (syntax->datum id))
+                                "Wrong type argument (want `~S'): ~S"
+                                (list '#,type-name #,type-name)
+                                #f))
+                   (struct-ref #,type-name #,slot)))))
 
          (define (setter rtd type-name field slot)
-           #`(define #,(make-id rtd 'set- type-name '- field '!)
+           (define id (make-id rtd 'set- type-name '- field '!))
+           #`(define #,id
                (let ((rtd #,rtd))
                  (lambda (#,type-name val)
-                   (if (eq? (struct-vtable #,type-name) rtd)
-                       (struct-set! #,type-name #,slot val)
-                       (%record-type-error rtd #,type-name))))))
+                   (unless (eq? (struct-vtable #,type-name) rtd)
+                     (scm-error 'wrong-type-arg
+                                #,(symbol->string (syntax->datum id))
+                                "Wrong type argument (want `~S'): ~S"
+                                (list '#,type-name #,type-name)
+                                #f))
+                   (struct-set! #,type-name #,slot val)))))
 
          (define (accessors rtd type-name fields n exp)
            (syntax-case fields ()
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index c2ea06e..625a3db 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -1,6 +1,6 @@
 ;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; 
coding: utf-8 -*-
 ;;;;
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2019 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
@@ -87,4 +87,52 @@
       (with-locale "en_US.utf8"
         (string-prefix? "#<fŏŏ"
                         (with-output-to-string
-                          (lambda () (display (make-fŏŏ 1 2)))))))))
+                          (lambda () (display (make-fŏŏ 1 2))))))))
+
+  (with-test-prefix "subtyping"
+    (let ()
+      (define a (make-record-type 'a '(s t)))
+      (define b (make-record-type 'b '(u v) #:final? #f))
+      (define c (make-record-type 'c '(w x) #:parent b))
+
+      (pass-if "default final: a"
+        (and (memq 'final (record-type-flags a)) #t))
+      (pass-if "default final: b"
+        (not (memq 'final (record-type-flags b))))
+      (pass-if "default final: c"
+        (and (memq 'final (record-type-flags c)) #t))
+
+      (pass-if-exception "subtyping final: a" '(misc-error . "final")
+        (make-record-type 'd '(y x) #:parent a))
+      (pass-if-exception "subtyping final: c" '(misc-error . "final")
+        (make-record-type 'd '(y x) #:parent c))
+
+      (pass-if-equal "fields of subtype" '(u v w x)
+        (record-type-fields c))
+
+      (pass-if "final predicate: a? a"
+        ((record-predicate a) ((record-constructor a) 1 2)))
+      (pass-if "final predicate: a? b"
+        (not ((record-predicate a) ((record-constructor b) 1 2))))
+
+      (pass-if "non-final predicate: b? a"
+        (not ((record-predicate b) ((record-constructor a) 1 2))))
+      (pass-if "non-final predicate: b? b"
+        ((record-predicate b) ((record-constructor b) 1 2)))
+      (pass-if "non-final predicate: b? c"
+        ((record-predicate b) ((record-constructor c) 1 2 3 4)))
+
+      (pass-if "final predicate: c? a"
+        (not ((record-predicate c) ((record-constructor a) 1 2))))
+      (pass-if "final predicate: c? b"
+        (not ((record-predicate c) ((record-constructor b) 1 2))))
+      (pass-if "final predicate: c? c"
+        ((record-predicate c) ((record-constructor c) 1 2 3 4)))
+
+      (pass-if-equal "b accessor on b" 1
+        ((record-accessor b 'u) ((record-constructor b) 1 2)))
+      (pass-if-equal "b accessor on c" 1
+        ((record-accessor b 'u) ((record-constructor c) 1 2 3 4)))
+
+      (pass-if-equal "c accessor on c" 3
+        ((record-accessor c 'w) ((record-constructor c) 1 2 3 4))))))