[Guile-commits] 02/06: Guile `make-record-type' supports non-generative definition

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 7a8e314d31ef8d40dd692bc27a93bc30c328e2b7
Author: Andy Wingo <address@hidden>
Date:   Sun Oct 27 20:51:49 2019 +0100

    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 9b6cd88..d7af775 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 8ea7632..3b2cdf7 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 cd4dfef..10f42ec 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)))))