summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-10-27 21:28:21 +0100
committerAndy Wingo <wingo@pobox.com>2019-10-27 21:31:18 +0100
commitf963bdf02d7dd316884ccc9d590b3a7327406422 (patch)
tree2586cfc78892048f0c740213bf4cb134ddfe1127
parent7a8e314d31ef8d40dd692bc27a93bc30c328e2b7 (diff)
downloadguile-f963bdf02d7dd316884ccc9d590b3a7327406422.tar.gz
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.
-rw-r--r--doc/ref/api-data.texi19
-rw-r--r--module/ice-9/boot-9.scm24
-rw-r--r--module/srfi/srfi-35.scm5
-rw-r--r--test-suite/tests/records.test24
4 files changed, 51 insertions, 21 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index d7af7754a..3385571c2 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 3b2cdf709..ecf1fec5a 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 ffb372632..e4246bb7d 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 10f42ec76..5ec784c49 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)))))