From 7a8e314d31ef8d40dd692bc27a93bc30c328e2b7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 27 Oct 2019 20:51:49 +0100 Subject: Guile `make-record-type' supports non-generative definition * module/ice-9/boot-9.scm (prefab-record-types): New definition. (make-record-type): Add #:uid keyword. * test-suite/tests/records.test ("records"): Add tests. * doc/ref/api-data.texi (Records): Document #:uid --- doc/ref/api-data.texi | 14 ++++++++- module/ice-9/boot-9.scm | 67 +++++++++++++++++++++++++++++-------------- test-suite/tests/records.test | 24 +++++++++++++++- 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))))) -- cgit v1.2.3