diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-27 20:03:51 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-27 20:03:51 +0100 |
commit | 958aa8b313f771c281168ed56b23f2f8aebb72cc (patch) | |
tree | 6d26b293c454b979aa6133a381f3e1a6446af90e | |
parent | 04615d3c206e5ab612286beffc3e7e5bae1d3af4 (diff) | |
download | guile-958aa8b313f771c281168ed56b23f2f8aebb72cc.tar.gz |
Change record type "flags" field to "properties"
* module/ice-9/boot-9.scm (record-type-properties): Rename from
record-type-flags.
(record-type-final?): New accessor.
(make-record-type):
(define-record-type):
* test-suite/tests/records.test ("records"): Adapt.
-rw-r--r-- | module/ice-9/boot-9.scm | 13 | ||||
-rw-r--r-- | test-suite/tests/records.test | 9 |
2 files changed, 11 insertions, 11 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 8dd3b3857..8ea763259 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1220,11 +1220,14 @@ VALUE." (error 'not-a-record-type rtd)) (struct-ref rtd (+ 2 vtable-offset-user))) -(define (record-type-flags rtd) +(define (record-type-properties rtd) (unless (record-type? rtd) (error 'not-a-record-type rtd)) (struct-ref rtd (+ 3 vtable-offset-user))) +(define (record-type-final? rtd) + (assq-ref (record-type-properties rtd) 'final?)) + (define (record-type-parents rtd) (unless (record-type? rtd) (error 'not-a-record-type rtd)) @@ -1285,7 +1288,7 @@ VALUE." (define parents (cond ((record-type? parent) - (when (memq 'final (record-type-flags parent)) + (when (record-type-final? parent) (error "parent type is final")) (let* ((parent-parents (record-type-parents parent)) (parent-nparents (vector-length parent-parents)) @@ -1345,7 +1348,7 @@ VALUE." name-sym computed-fields #f ; Constructor initialized below. - (if final? '(final) '()) + (if final? '((final? . #t)) '()) parents)) (struct-set! rtd (+ vtable-offset-user 2) @@ -1379,7 +1382,7 @@ VALUE." (define (record-predicate rtd) (unless (record-type? rtd) (error 'not-a-record-type rtd)) - (if (memq 'final (record-type-flags rtd)) + (if (record-type-final? rtd) (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))) (let ((pos (vector-length (record-type-parents rtd)))) ;; Extensible record types form a forest of DAGs, with each @@ -2066,7 +2069,7 @@ name extensions listed in %load-extensions." '#,type-name '#,(field-list fields) #f ; constructor; set later - '() ; flags + '() ; properties #())) ; parents (set-struct-vtable-name! #,rtd '#,type-name))))) diff --git a/test-suite/tests/records.test b/test-suite/tests/records.test index f88c7dfdb..cd4dfefb9 100644 --- a/test-suite/tests/records.test +++ b/test-suite/tests/records.test @@ -95,12 +95,9 @@ (define b (make-record-type 'b '(u v) #:final? #f)) (define c (make-record-type 'c '(w x) #:parent b)) - (pass-if "default final: a" - (and (memq 'final (record-type-flags a)) #t)) - (pass-if "default final: b" - (not (memq 'final (record-type-flags b)))) - (pass-if "default final: c" - (and (memq 'final (record-type-flags c)) #t)) + (pass-if (record-type-final? a)) + (pass-if (not (record-type-final? b))) + (pass-if (record-type-final? c)) (pass-if-exception "subtyping final: a" '(misc-error . "final") (make-record-type 'd '(y x) #:parent a)) |