summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-10-28 16:58:22 +0100
committerAndy Wingo <wingo@pobox.com>2019-10-28 16:59:58 +0100
commit315fabdfe7122737ca9a804097ff16dabfd7a63a (patch)
treebedc0edf9abe43bad1d3bd6535c710019be7dca8
parentf963bdf02d7dd316884ccc9d590b3a7327406422 (diff)
downloadguile-315fabdfe7122737ca9a804097ff16dabfd7a63a.tar.gz
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.
-rw-r--r--doc/ref/api-data.texi11
-rw-r--r--module/ice-9/boot-9.scm43
-rw-r--r--test-suite/tests/records.test32
3 files changed, 78 insertions, 8 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 3385571c2..2708ad5c7 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 ecf1fec5a..d310a13cf 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 5ec784c49..375733419 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)))))