summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-data.texi14
-rw-r--r--module/ice-9/boot-9.scm67
-rw-r--r--test-suite/tests/records.test24
3 files changed, 81 insertions, 24 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 9b6cd88d4..d7af7754a 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8631,7 +8631,7 @@ 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}]
+ [#:final?=@code{#t}] [#:parent=@code{#f}] [#:uid=@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
@@ -8659,6 +8659,18 @@ work on any instance of a subtype.
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.
+
+@cindex prefab record types
+@cindex record types, prefab
+@cindex record types, nongenerative
+Generally speaking, calling @code{make-record-type} returns a fresh
+record type; it @emph{generates} new record types. However sometimes
+you only want to define a record type if one hasn't been defined
+already. For a @emph{nongenerative} record type definition, pass a
+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.
@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 8ea763259..3b2cdf709 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1233,8 +1233,11 @@ VALUE."
(error 'not-a-record-type rtd))
(struct-ref rtd (+ 4 vtable-offset-user)))
+(define prefab-record-types
+ (make-hash-table))
+
(define* (make-record-type type-name fields #:optional printer #:key
- (final? #t) parent)
+ (final? #t) parent uid)
;; Pre-generate constructors for nfields < 20.
(define-syntax make-constructor
(lambda (x)
@@ -1338,27 +1341,47 @@ VALUE."
(else
(error "expected a symbol for record type name" type-name))))
- (define rtd
- (make-struct/no-tail
- record-type-vtable
- (make-struct-layout
- (apply string-append
- (map (lambda (f) "pw") computed-fields)))
- (or printer default-record-printer)
- name-sym
- computed-fields
- #f ; Constructor initialized below.
- (if final? '((final? . #t)) '())
- parents))
-
- (struct-set! rtd (+ vtable-offset-user 2)
- (make-constructor rtd (length computed-fields)))
-
- ;; Temporary solution: Associate a name to the record type descriptor
- ;; so that the object system can create a wrapper class for it.
- (set-struct-vtable-name! rtd name-sym)
-
- rtd)
+ (define properties
+ (if final? '((final? . #t)) '()))
+
+ (cond
+ ((and uid (hashq-ref prefab-record-types uid))
+ => (lambda (rtd)
+ (unless (and (equal? (record-type-name rtd) name-sym)
+ (equal? (record-type-fields rtd) computed-fields)
+ (not printer)
+ (equal? (record-type-properties rtd) properties)
+ (equal? (record-type-parents rtd) parents))
+ (error "prefab record type declaration incompatible with previous"
+ rtd))
+ rtd))
+ (else
+ (let ((rtd (make-struct/no-tail
+ record-type-vtable
+ (make-struct-layout
+ (apply string-append
+ (map (lambda (f) "pw") computed-fields)))
+ (or printer default-record-printer)
+ name-sym
+ computed-fields
+ #f ; Constructor initialized below.
+ properties
+ parents)))
+
+ (struct-set! rtd (+ vtable-offset-user 2)
+ (make-constructor rtd (length computed-fields)))
+
+ ;; Temporary solution: Associate a name to the record type
+ ;; descriptor so that the object system can create a wrapper
+ ;; class for it.
+ (set-struct-vtable-name! rtd name-sym)
+
+ (when uid
+ (unless (symbol? uid)
+ (error "UID for prefab record type should be a symbol" uid))
+ (hashq-set! prefab-record-types uid rtd))
+
+ rtd))))
(define record-constructor
(case-lambda
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index cd4dfefb9..10f42ec76 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -132,4 +132,26 @@
((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))))))
+ ((record-accessor c 'w) ((record-constructor c) 1 2 3 4)))))
+
+ (with-test-prefix "prefab types"
+ (let ()
+ (define uid 'ANhUpf2WpNnF2XIVLxq@IkavIc5wbqe8)
+ (define a (make-record-type 'a '(s t) #:uid uid))
+ (define b (make-record-type 'b '() #:final? #f))
+
+ (pass-if (eq? a (make-record-type 'a '(s t) #:uid uid)))
+ (pass-if-exception "different name" '(misc-error . "incompatible")
+ (make-record-type 'b '(s t) #:uid uid))
+ (pass-if-exception "different fields" '(misc-error . "incompatible")
+ (make-record-type 'a '(u v) #:uid uid))
+ (pass-if-exception "fewer fields" '(misc-error . "incompatible")
+ (make-record-type 'a '(s) #:uid uid))
+ (pass-if-exception "more fields" '(misc-error . "incompatible")
+ (make-record-type 'a '(s t u) #:uid uid))
+ (pass-if-exception "adding a parent" '(misc-error . "incompatible")
+ (make-record-type 'a '(s t) #:parent b #:uid uid))
+ (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)))))