[Guile-commits] 04/06: Add support for immutable fields in core records

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 315fabdfe7122737ca9a804097ff16dabfd7a63a
Author: Andy Wingo <address@hidden>
Date:   Mon Oct 28 16:58:22 2019 +0100

    Add support for immutable fields in core records
    
    * module/ice-9/boot-9.scm (make-record-type): Allow (mutable NAME)
      or (immutable NAME) as a field name, and record field mutability in a
      bitfield.
      (record-modifier): Throw an error if the field isn't mutable.
    * test-suite/tests/records.test ("records"): Add tests.
    * doc/ref/api-data.texi (Records): Update.
---
 doc/ref/api-data.texi         | 11 +++++++++--
 module/ice-9/boot-9.scm       | 43 ++++++++++++++++++++++++++++++++++++++-----
 test-suite/tests/records.test | 32 +++++++++++++++++++++++++++++++-
 3 files changed, 78 insertions(+), 8 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 3385571..2708ad5 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -8637,8 +8637,10 @@ Create and return a new @dfn{record-type descriptor}.
 
 @var{type-name} is a string naming the type.  Currently it's only used
 in the printed representation of records, and in diagnostics.
-@var{field-names} is a list of symbols naming the fields of a record
-of the type.  Duplicates are not allowed among these symbols.
+@var{field-names} is a list of elements of the form @code{(immutable
+@var{name})}, @code{(mutable @var{name})}, or @var{name}, where
+@var{name} are symbols naming the fields of a record of the type.
+Duplicates are not allowed among these symbols.
 
 @example
 (make-record-type "employee" '(name age salary))
@@ -8680,6 +8682,11 @@ 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.
+
+Fields are mutable by default, meaning that @code{record-modifier} will
+return a procedure that can update a record in place.  Specifying a
+field using the form @code{(immutable @var{name})} instead marks a field
+as immutable.
 @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 ecf1fec..d310a13 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1191,10 +1191,10 @@ VALUE."
 ;;
 ;; It should print OBJECT to PORT.
 
-;; 0: type-name, 1: fields, 2: constructor, 3: flags, 4: parents
+;; 0: type-name, 1: fields, 2: constructor, 3: flags, 4: parents 5: mutable 
bitmask
 (define record-type-vtable
   (let ((s (make-vtable (string-append standard-vtable-fields
-                                       "pwpwpwpwpw")
+                                       "pwpwpwpwpwpw")
                         (lambda (s p)
                           (display "#<record-type " p)
                           (display (record-type-name s) p)
@@ -1235,6 +1235,11 @@ VALUE."
     (error 'not-a-record-type rtd))
   (struct-ref rtd (+ 4 vtable-offset-user)))
 
+(define (record-type-mutable-fields rtd)
+  (unless (record-type? rtd)
+    (error 'not-a-record-type rtd))
+  (struct-ref rtd (+ 5 vtable-offset-user)))
+
 (define prefab-record-types
   (make-hash-table))
 
@@ -1329,12 +1334,36 @@ VALUE."
           (cons field tail))))
 
   (define computed-fields
-    (begin
+    (let ((fields (map (lambda (field)
+                         (cond
+                          ((symbol? field) field)
+                          (else
+                           (unless (and (pair? field)
+                                        (memq (car field) '(mutable immutable))
+                                        (pair? (cdr field))
+                                        (null? (cddr field)))
+                             (error (error "bad field declaration" field)))
+                           (cadr field))))
+                       fields)))
       (check-fields fields)
       (if parent
           (append-fields (record-type-fields parent) fields)
           fields)))
 
+  (define mutable-fields
+    (let lp ((fields fields)
+             (i (if parent (length (record-type-fields parent)) 0))
+             (mutable (if parent (record-type-mutable-fields parent) 0)))
+      (if (null? fields)
+          mutable
+          (let ((field (car fields)))
+            (lp (cdr fields)
+                (1+ i)
+                (if (or (not (pair? field))
+                        (eq? (car field) 'mutable))
+                    (logior mutable (ash 1 i))
+                    mutable))))))
+
   (define name-sym
     (cond
      ((symbol? type-name) type-name)
@@ -1359,7 +1388,8 @@ VALUE."
                       (equal? (record-type-fields rtd) computed-fields)
                       (not printer)
                       (equal? (record-type-properties rtd) properties)
-                      (equal? (record-type-parents rtd) parents))
+                      (equal? (record-type-parents rtd) parents)
+                      (equal? (record-type-mutable-fields rtd) mutable-fields))
            (error "prefab record type declaration incompatible with previous"
                   rtd))
          rtd))
@@ -1374,7 +1404,8 @@ VALUE."
                 computed-fields
                 #f                      ; Constructor initialized below.
                 properties
-                parents)))
+                parents
+                mutable-fields)))
 
       (struct-set! rtd (+ vtable-offset-user 2)
                    (make-constructor rtd (length computed-fields)))
@@ -1446,6 +1477,8 @@ VALUE."
         (pos (or (list-index (record-type-fields rtd) field-name)
                  (error 'no-such-field field-name)))
         (pred (record-predicate rtd)))
+    (unless (logbit? pos (record-type-mutable-fields rtd))
+      (error "field is immutable" rtd field-name))
     (lambda (obj val)
       (unless (pred obj)
         (scm-error 'wrong-type-arg "record-modifier"
diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test
index 5ec784c..3757334 100644
--- a/test-suite/tests/records.test
+++ b/test-suite/tests/records.test
@@ -166,4 +166,34 @@
       (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)))))
+        (make-record-type 'd '() #:opaque? #f #:parent a))))
+
+  (with-test-prefix "immutable fields"
+    (let ()
+      (define a (make-record-type 'a '(s t (mutable u) (immutable v))
+                                  #:extensible? #t))
+      (define b (make-record-type 'b '(w (immutable x)) #:parent a))
+
+      (pass-if-exception "bad field" '(misc-error . "field")
+        (make-record-type 'a '("foo")))
+      (pass-if-exception "bad field" '(misc-error . "field")
+        (make-record-type 'a '((mutable u x))))
+      (pass-if-exception "bad field" '(misc-error . "field")
+        (make-record-type 'a '((qux u))))
+      (pass-if-equal (record-type-mutable-fields a) #b0111)
+      (pass-if-equal (record-type-mutable-fields b) #b010111)
+
+      (pass-if (procedure? (record-modifier a 's)))
+      (pass-if (procedure? (record-modifier a 't)))
+      (pass-if (procedure? (record-modifier a 'u)))
+      (pass-if-exception "immutable" '(misc-error . "immutable")
+        (record-modifier a 'v))
+
+      (pass-if (procedure? (record-modifier b 's)))
+      (pass-if (procedure? (record-modifier b 't)))
+      (pass-if (procedure? (record-modifier b 'u)))
+      (pass-if-exception "immutable" '(misc-error . "immutable")
+        (record-modifier b 'v))
+      (pass-if (procedure? (record-modifier b 'w)))
+      (pass-if-exception "immutable" '(misc-error . "immutable")
+        (record-modifier b 'x)))))