diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-28 16:58:22 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-28 16:59:58 +0100 |
commit | 315fabdfe7122737ca9a804097ff16dabfd7a63a (patch) | |
tree | bedc0edf9abe43bad1d3bd6535c710019be7dca8 /module | |
parent | f963bdf02d7dd316884ccc9d590b3a7327406422 (diff) | |
download | guile-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.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 43 |
1 files changed, 38 insertions, 5 deletions
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" |