mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add support for immutable fields in core records

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-10-28 16:58:22 +01:00
parent f963bdf02d
commit 315fabdfe7
3 changed files with 78 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

11
doc/ref/api-data.texi
View file

@ -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

43
module/ice-9/boot-9.scm
View file

@ -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"

32
test-suite/tests/records.test
View file

@ -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)))))