[Guile-commits] 01/06: Change record type "flags" field to "properties"

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 958aa8b313f771c281168ed56b23f2f8aebb72cc
Author: Andy Wingo <address@hidden>
Date:   Sun Oct 27 20:03:51 2019 +0100

    Change record type "flags" field to "properties"
    
    * module/ice-9/boot-9.scm (record-type-properties): Rename from
      record-type-flags.
      (record-type-final?): New accessor.
      (make-record-type):
      (define-record-type):
    * test-suite/tests/records.test ("records"): Adapt.
---
 module/ice-9/boot-9.scm       | 13 ++++++++-----
 test-suite/tests/records.test |  9 +++------
 2 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8dd3b38..8ea7632 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1220,11 +1220,14 @@ VALUE."
     (error 'not-a-record-type rtd))
   (struct-ref rtd (+ 2 vtable-offset-user)))
 
-(define (record-type-flags rtd)
+(define (record-type-properties rtd)
   (unless (record-type? rtd)
     (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-parents rtd)
   (unless (record-type? rtd)
     (error 'not-a-record-type rtd))
@@ -1285,7 +1288,7 @@ VALUE."
   (define parents
     (cond
      ((record-type? parent)
-      (when (memq 'final (record-type-flags parent))
+      (when (record-type-final? parent)
         (error "parent type is final"))
       (let* ((parent-parents (record-type-parents parent))
              (parent-nparents (vector-length parent-parents))
@@ -1345,7 +1348,7 @@ VALUE."
      name-sym
      computed-fields
      #f ; Constructor initialized below.
-     (if final? '(final) '())
+     (if final? '((final? . #t)) '())
      parents))
 
   (struct-set! rtd (+ vtable-offset-user 2)
@@ -1379,7 +1382,7 @@ VALUE."
 (define (record-predicate rtd)
   (unless (record-type? rtd)
     (error 'not-a-record-type rtd))
-  (if (memq 'final (record-type-flags rtd))
+  (if (record-type-final? rtd)
       (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))
       (let ((pos (vector-length (record-type-parents rtd))))
         ;; Extensible record types form a forest of DAGs, with each
@@ -2066,7 +2069,7 @@ name extensions listed in %load-extensions."
                                  '#,type-name
                                  '#,(field-list fields)
                                  #f ; constructor; set later
-                                 '() ; flags
+                                 '() ; properties
                                  #())) ; parents
                               (set-struct-vtable-name! #,rtd '#,type-name)))))
 
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index f88c7df..cd4dfef 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -95,12 +95,9 @@
       (define b (make-record-type 'b '(u v) #:final? #f))
       (define c (make-record-type 'c '(w x) #:parent b))
 
-      (pass-if "default final: a"
-        (and (memq 'final (record-type-flags a)) #t))
-      (pass-if "default final: b"
-        (not (memq 'final (record-type-flags b))))
-      (pass-if "default final: c"
-        (and (memq 'final (record-type-flags c)) #t))
+      (pass-if (record-type-final? a))
+      (pass-if (not (record-type-final? b)))
+      (pass-if (record-type-final? c))
 
       (pass-if-exception "subtyping final: a" '(misc-error . "final")
         (make-record-type 'd '(y x) #:parent a))