diff options
-rw-r--r-- | doc/ref/api-data.texi | 11 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 43 | ||||
-rw-r--r-- | 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 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))))) |