diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-27 21:28:21 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-27 21:31:18 +0100 |
commit | f963bdf02d7dd316884ccc9d590b3a7327406422 (patch) | |
tree | 2586cfc78892048f0c740213bf4cb134ddfe1127 | |
parent | 7a8e314d31ef8d40dd692bc27a93bc30c328e2b7 (diff) | |
download | guile-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.texi | 19 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 24 | ||||
-rw-r--r-- | module/srfi/srfi-35.scm | 5 | ||||
-rw-r--r-- | 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 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))))) |