[Guile-commits] 03/06: Rename final? record type flag; add support for opaque?

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit f963bdf02d7dd316884ccc9d590b3a7327406422
Author: Andy Wingo <address@hidden>
Date:   Sun Oct 27 21:28:21 2019 +0100

    Rename final? record type flag; add support for opaque?
    
    * module/ice-9/boot-9.scm (record-type-extensible?): Rename from
      record-type-final?, with the opposite sense.
      (record-type-opaque?): New accessor.
      (make-record-type): Change #:final? to #:extensible?, with the
      opposite meaning.  Add #:opaque? arg.
    * test-suite/tests/records.test ("records"): Add opaque tests; update
      extensible tests.
    * doc/ref/api-data.texi (Records): Update.
    * module/srfi/srfi-35.scm (&condition, make-condition-type): Update for
      make-record-type API change.
---
 doc/ref/api-data.texi         | 19 ++++++++++++++-----
 module/ice-9/boot-9.scm       | 24 ++++++++++++++++--------
 module/srfi/srfi-35.scm       |  5 +++--
 test-suite/tests/records.test | 24 ++++++++++++++++++------
 4 files changed, 51 insertions(+), 21 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index d7af775..3385571 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8631,7 +8631,8 @@ promise that records are disjoint with other Scheme types.
 @end deffn
 
 @deffn {Scheme Procedure} make-record-type type-name field-names [print] @
-       [#:final?=@code{#t}] [#:parent=@code{#f}] [#:uid=@code{#f}]
+       [#:parent=@code{#f}] [#:uid=@code{#f}] @
+       [#:extensible?=@code{#f}] [#:opaque?] @
 Create and return a new @dfn{record-type descriptor}.
 
 @var{type-name} is a string naming the type.  Currently it's only used
@@ -8654,11 +8655,11 @@ 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
+@cindex extensible record types
+@cindex record types, extensible
 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.
+overhead, prevent extensibility by passing @code{#:extensible? #f}.
+By default, record types in Guile are not extensible.
 
 @cindex prefab record types
 @cindex record types, prefab
@@ -8671,6 +8672,14 @@ symbol as the @code{#:uid} keyword parameter.  If a 
record with the
 given @var{uid} was already defined, it will be returned instead.  The
 type name, fields, parent (if any), and so on for the previously-defined
 type must be compatible.
+
+@cindex record types, opaque
+R6RS defines a notion of ``opaque'' record types.  Given an instance of
+an opaque record type, one cannot obtain a run-time representation of
+the record type.  @xref{rnrs records procedural}, for full details.  The
+@code{#:opaque?} flag is used by Guile's R6RS layer to record this
+information.  The default is determined by whether the parent type, if
+any, was opaque.
 @end deffn
 
 @deffn {Scheme Procedure} record-constructor rtd
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 3b2cdf7..ecf1fec 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1225,8 +1225,10 @@ VALUE."
     (error 'not-a-record-type rtd))
   (struct-ref rtd (+ 3 vtable-offset-user)))
 
-(define (record-type-final? rtd)
-  (assq-ref (record-type-properties rtd) 'final?))
+(define (record-type-extensible? rtd)
+  (assq-ref (record-type-properties rtd) 'extensible?))
+(define (record-type-opaque? rtd)
+  (assq-ref (record-type-properties rtd) 'opaque?))
 
 (define (record-type-parents rtd)
   (unless (record-type? rtd)
@@ -1237,7 +1239,8 @@ VALUE."
   (make-hash-table))
 
 (define* (make-record-type type-name fields #:optional printer #:key
-                           (final? #t) parent uid)
+                           parent uid extensible?
+                           (opaque? (and=> parent record-type-opaque?)))
   ;; Pre-generate constructors for nfields < 20.
   (define-syntax make-constructor
     (lambda (x)
@@ -1291,8 +1294,10 @@ VALUE."
   (define parents
     (cond
      ((record-type? parent)
-      (when (record-type-final? parent)
+      (unless (record-type-extensible? parent)
         (error "parent type is final"))
+      (when (and (record-type-opaque? parent) (not opaque?))
+        (error "can't make non-opaque subtype of opaque type"))
       (let* ((parent-parents (record-type-parents parent))
              (parent-nparents (vector-length parent-parents))
              (parents (make-vector (1+ parent-nparents))))
@@ -1342,7 +1347,10 @@ VALUE."
       (error "expected a symbol for record type name" type-name))))
 
   (define properties
-    (if final? '((final? . #t)) '()))
+    (let ((maybe-acons (lambda (k v tail)
+                         (if v (acons k v tail) tail))))
+      (maybe-acons 'extensible? extensible?
+                   (maybe-acons 'opaque? opaque? '()))))
 
   (cond
    ((and uid (hashq-ref prefab-record-types uid))
@@ -1405,8 +1413,7 @@ VALUE."
 (define (record-predicate rtd)
   (unless (record-type? rtd)
     (error 'not-a-record-type rtd))
-  (if (record-type-final? rtd)
-      (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))
+  (if (record-type-extensible? rtd)
       (let ((pos (vector-length (record-type-parents rtd))))
         ;; Extensible record types form a forest of DAGs, with each
         ;; record type recording an ordered vector of its ancestors.  If
@@ -1418,7 +1425,8 @@ VALUE."
                  (or (eq? v rtd)
                      (let ((parents (record-type-parents v)))
                        (and (< pos (vector-length parents))
-                            (eq? (vector-ref parents pos) rtd))))))))))
+                            (eq? (vector-ref parents pos) rtd))))))))
+      (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))))
 
 (define (record-accessor rtd field-name)
   (let ((type-name (record-type-name rtd))
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index ffb3726..e4246bb 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -62,7 +62,7 @@
 
 ;; FIXME: Perhaps use a `define-record-type' which allows for parent types.
 (define &condition
-  (make-record-type '&condition '() print-condition #:final? #f))
+  (make-record-type '&condition '() print-condition #:extensible? #t))
 
 (define (make-condition-type id parent field-names)
   "Return a new condition type named @var{id}, inheriting from
@@ -72,7 +72,8 @@ not contain names already used by @var{parent} or one of its
 supertypes."
   (unless (condition-type? parent)
     (error "parent is not a condition type" parent))
-  (make-record-type id field-names print-condition #:final? #f #:parent 
parent))
+  (make-record-type id field-names print-condition #:parent parent
+                    #:extensible? #t))
 
 (define (condition-type? obj)
   "Return true if OBJ is a condition type."
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index 10f42ec..5ec784c 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -92,12 +92,12 @@
   (with-test-prefix "subtyping"
     (let ()
       (define a (make-record-type 'a '(s t)))
-      (define b (make-record-type 'b '(u v) #:final? #f))
+      (define b (make-record-type 'b '(u v) #:extensible? #t))
       (define c (make-record-type 'c '(w x) #:parent b))
 
-      (pass-if (record-type-final? a))
-      (pass-if (not (record-type-final? b)))
-      (pass-if (record-type-final? c))
+      (pass-if (not (record-type-extensible? a)))
+      (pass-if (record-type-extensible? b))
+      (pass-if (not (record-type-extensible? c)))
 
       (pass-if-exception "subtyping final: a" '(misc-error . "final")
         (make-record-type 'd '(y x) #:parent a))
@@ -138,7 +138,7 @@
     (let ()
       (define uid 'ANhUpf2WpNnF2XIVLxq@IkavIc5wbqe8)
       (define a (make-record-type 'a '(s t) #:uid uid))
-      (define b (make-record-type 'b '() #:final? #f))
+      (define b (make-record-type 'b '() #:extensible? #t))
 
       (pass-if (eq? a (make-record-type 'a '(s t) #:uid uid)))
       (pass-if-exception "different name" '(misc-error . "incompatible")
@@ -154,4 +154,16 @@
       (pass-if-exception "specifying a printer" '(misc-error . "incompatible")
         (make-record-type 'a '(s t) pk #:uid uid))
       (pass-if-exception "non-final" '(misc-error . "incompatible")
-        (make-record-type 'a '(s t) #:final? #f #:uid uid)))))
+        (make-record-type 'a '(s t) #:extensible? #t #:uid uid))))
+
+  (with-test-prefix "opaque types"
+    (let ()
+      (define a (make-record-type 'a '() #:extensible? #t #:opaque? #t))
+      (define b (make-record-type 'b '()))
+      (define c (make-record-type 'c '() #:parent a))
+
+      (pass-if (record-type-opaque? a))
+      (pass-if (not (record-type-opaque? b)))
+      (pass-if (record-type-opaque? c))
+      (pass-if-exception "non-opaque" '(misc-error . "opaque")
+        (make-record-type 'd '() #:opaque? #f #:parent a)))))